theory Affine_Arithmetic_Auxiliarities imports "HOL-Analysis.Multivariate_Analysis" begin subsection ‹@{term sum_list}› lemma sum_list_nth_eqI: fixes xs ys::"'a::monoid_add list" shows "length xs = length ys ⟹ (⋀x y. (x, y) ∈ set (zip xs ys) ⟹ x = y) ⟹ sum_list xs = sum_list ys" by (induct xs ys rule: list_induct2) auto lemma fst_sum_list: "fst (sum_list xs) = sum_list (map fst xs)" by (induct xs) auto lemma snd_sum_list: "snd (sum_list xs) = sum_list (map snd xs)" by (induct xs) auto lemma take_greater_eqI: "take c xs = take c ys ⟹ c ≥ a ⟹ take a xs = take a ys" proof (induct xs arbitrary: a c ys) case (Cons x xs) note ICons = Cons thus ?case proof (cases a) case (Suc b) thus ?thesis using Cons(2,3) proof (cases ys) case (Cons z zs) from ICons obtain d where c: "c = Suc d" by (auto simp: Cons Suc dest!: Suc_le_D) show ?thesis using ICons(2,3) by (auto simp: Suc Cons c intro: ICons(1)) qed simp qed simp qed (metis le_0_eq take_eq_Nil) lemma take_max_eqD: "take (max a b) xs = take (max a b) ys ⟹ take a xs = take a ys ∧ take b xs = take b ys" by (metis max.cobounded1 max.cobounded2 take_greater_eqI) lemma take_Suc_eq: "take (Suc n) xs = (if n < length xs then take n xs @ [xs ! n] else xs)" by (auto simp: take_Suc_conv_app_nth) subsection ‹Radiant and Degree› definition "rad_of w = w * pi / 180" definition "deg_of w = 180 * w / pi" lemma rad_of_inverse[simp]: "deg_of (rad_of w) = w" and deg_of_inverse[simp]: "rad_of (deg_of w) = w" by (auto simp: deg_of_def rad_of_def) lemma deg_of_monoI: "x ≤ y ⟹ deg_of x ≤ deg_of y" by (auto simp: deg_of_def intro!: divide_right_mono) lemma rad_of_monoI: "x ≤ y ⟹ rad_of x ≤ rad_of y" by (auto simp: rad_of_def) lemma deg_of_strict_monoI: "x < y ⟹ deg_of x < deg_of y" by (auto simp: deg_of_def intro!: divide_strict_right_mono) lemma rad_of_strict_monoI: "x < y ⟹ rad_of x < rad_of y" by (auto simp: rad_of_def) lemma deg_of_mono[simp]: "deg_of x ≤ deg_of y ⟷ x ≤ y" using rad_of_monoI by (fastforce intro!: deg_of_monoI) lemma rad_of_mono[simp]: "rad_of x ≤ rad_of y ⟷ x ≤ y" using rad_of_monoI by (fastforce intro!: deg_of_monoI) lemma deg_of_strict_mono[simp]: "deg_of x < deg_of y ⟷ x < y" using rad_of_strict_monoI by (fastforce intro!: deg_of_strict_monoI) lemma rad_of_strict_mono[simp]: "rad_of x < rad_of y ⟷ x < y" using rad_of_strict_monoI by (fastforce intro!: deg_of_strict_monoI) lemma rad_of_lt_iff: "rad_of d < r ⟷ d < deg_of r" and rad_of_gt_iff: "rad_of d > r ⟷ d > deg_of r" and rad_of_le_iff: "rad_of d ≤ r ⟷ d ≤ deg_of r" and rad_of_ge_iff: "rad_of d ≥ r ⟷ d ≥ deg_of r" using rad_of_strict_mono[of d "deg_of r"] rad_of_mono[of d "deg_of r"] by auto end
section ‹Euclidean Space: Executability› theory Executable_Euclidean_Space imports "HOL-Analysis.Multivariate_Analysis" "List-Index.List_Index" "HOL-Library.Float" Affine_Arithmetic_Auxiliarities begin subsection ‹Ordered representation of Basis and Rounding of Components› class executable_euclidean_space = ordered_euclidean_space + fixes Basis_list eucl_down eucl_truncate_down eucl_truncate_up assumes eucl_down_def: "eucl_down p b = (∑i ∈ Basis. round_down p (b ∙ i) *⇩R i)" assumes eucl_truncate_down_def: "eucl_truncate_down q b = (∑i ∈ Basis. truncate_down q (b ∙ i) *⇩R i)" assumes eucl_truncate_up_def: "eucl_truncate_up q b = (∑i ∈ Basis. truncate_up q (b ∙ i) *⇩R i)" assumes Basis_list[simp]: "set Basis_list = Basis" assumes distinct_Basis_list[simp]: "distinct Basis_list" begin lemma length_Basis_list: "length Basis_list = card Basis" by (metis Basis_list distinct_Basis_list distinct_card) end lemma eucl_truncate_down_zero[simp]: "eucl_truncate_down p 0 = 0" by (auto simp: eucl_truncate_down_def truncate_down_zero) lemma eucl_truncate_up_zero[simp]: "eucl_truncate_up p 0 = 0" by (auto simp: eucl_truncate_up_def) subsection ‹Instantiations› instantiation real::executable_euclidean_space begin definition Basis_list_real :: "real list" where "Basis_list_real = [1]" definition "eucl_down prec b = round_down prec b" definition "eucl_truncate_down prec b = truncate_down prec b" definition "eucl_truncate_up prec b = truncate_up prec b" instance proof qed (auto simp: Basis_list_real_def eucl_down_real_def eucl_truncate_down_real_def eucl_truncate_up_real_def) end instantiation prod::(executable_euclidean_space, executable_euclidean_space) executable_euclidean_space begin definition Basis_list_prod :: "('a × 'b) list" where "Basis_list_prod = zip Basis_list (replicate (length (Basis_list::'a list)) 0) @ zip (replicate (length (Basis_list::'b list)) 0) Basis_list" definition "eucl_down p a = (eucl_down p (fst a), eucl_down p (snd a))" definition "eucl_truncate_down p a = (eucl_truncate_down p (fst a), eucl_truncate_down p (snd a))" definition "eucl_truncate_up p a = (eucl_truncate_up p (fst a), eucl_truncate_up p (snd a))" instance proof show "set Basis_list = (Basis::('a*'b) set)" by (auto simp: Basis_list_prod_def Basis_prod_def elim!: in_set_zipE) (auto simp: Basis_list[symmetric] in_set_zip in_set_conv_nth simp del: Basis_list) show "distinct (Basis_list::('a*'b)list)" using distinct_Basis_list[where 'a='a] distinct_Basis_list[where 'a='b] by (auto simp: Basis_list_prod_def Basis_list intro: distinct_zipI1 distinct_zipI2 elim!: in_set_zipE) qed (auto simp: eucl_down_prod_def eucl_truncate_down_prod_def eucl_truncate_up_prod_def sum_Basis_prod_eq inner_add_left inner_sum_left inner_Basis eucl_down_def eucl_truncate_down_def eucl_truncate_up_def intro!: euclidean_eqI[where 'a="'a*'b"]) end lemma eucl_truncate_down_Basis[simp]: "i ∈ Basis ⟹ eucl_truncate_down e x ∙ i = truncate_down e (x ∙ i)" by (simp add: eucl_truncate_down_def) lemma eucl_truncate_down_correct: "dist (x::'a::executable_euclidean_space) (eucl_down e x) ∈ {0..sqrt (DIM('a)) * 2 powr of_int (- e)}" proof - have "dist x (eucl_down e x) = sqrt (∑i∈Basis. (dist (x ∙ i) (eucl_down e x ∙ i))⇧2)" unfolding euclidean_dist_l2[where 'a='a] L2_set_def .. also have "… ≤ sqrt (∑i∈(Basis::'a set). ((2 powr of_int (- e))⇧2))" by (intro real_sqrt_le_mono sum_mono power_mono) (auto simp: dist_real_def eucl_down_def abs_round_down_le) finally show ?thesis by (simp add: real_sqrt_mult) qed lemma eucl_down: "eucl_down e (x::'a::executable_euclidean_space) ≤ x" by (auto simp add: eucl_le[where 'a='a] round_down eucl_down_def) lemma eucl_truncate_down: "eucl_truncate_down e (x::'a::executable_euclidean_space) ≤ x" by (auto simp add: eucl_le[where 'a='a] truncate_down) lemma eucl_truncate_down_le: "x ≤ y ⟹ eucl_truncate_down w x ≤ (y::'a::executable_euclidean_space)" using eucl_truncate_down by (rule order.trans) lemma eucl_truncate_up_Basis[simp]: "i ∈ Basis ⟹ eucl_truncate_up e x ∙ i = truncate_up e (x ∙ i)" by (simp add: eucl_truncate_up_def truncate_up_def) lemma eucl_truncate_up: "x ≤ eucl_truncate_up e (x::'a::executable_euclidean_space)" by (auto simp add: eucl_le[where 'a='a] round_up truncate_up_def) lemma eucl_truncate_up_le: "x ≤ y ⟹ x ≤ eucl_truncate_up e (y::'a::executable_euclidean_space)" using _ eucl_truncate_up by (rule order.trans) lemma eucl_truncate_down_mono: fixes x::"'a::executable_euclidean_space" shows "x ≤ y ⟹ eucl_truncate_down p x ≤ eucl_truncate_down p y" by (auto simp: eucl_le[where 'a='a] intro!: truncate_down_mono) lemma eucl_truncate_up_mono: fixes x::"'a::executable_euclidean_space" shows "x ≤ y ⟹ eucl_truncate_up p x ≤ eucl_truncate_up p y" by (auto simp: eucl_le[where 'a='a] intro!: truncate_up_mono) lemma infnorm[code]: fixes x::"'a::executable_euclidean_space" shows "infnorm x = fold max (map (λi. abs (x ∙ i)) Basis_list) 0" by (auto simp: Max.set_eq_fold[symmetric] infnorm_Max[symmetric] infnorm_pos_le intro!: max.absorb2[symmetric]) declare Inf_real_def[code del] declare Sup_real_def[code del] declare Inf_prod_def[code del] declare Sup_prod_def[code del] declare [[code abort: "Inf::real set ⇒ real"]] declare [[code abort: "Sup::real set ⇒ real"]] declare [[code abort: "Inf::('a::Inf * 'b::Inf) set ⇒ 'a * 'b"]] declare [[code abort: "Sup::('a::Sup * 'b::Sup) set ⇒ 'a * 'b"]] lemma nth_Basis_list_in_Basis[simp]: "n < length (Basis_list::'a::executable_euclidean_space list) ⟹ Basis_list ! n ∈ (Basis::'a set)" by (metis Basis_list nth_mem) subsection ‹Representation as list› lemma nth_eq_iff_index: "distinct xs ⟹ n < length xs ⟹ xs ! n = i ⟷ n = index xs i" using index_nth_id by fastforce lemma in_Basis_index_Basis_list: "i ∈ Basis ⟹ i = Basis_list ! index Basis_list i" by simp lemmas [simp] = length_Basis_list lemma sum_Basis_sum_nth_Basis_list: "(∑i∈Basis. f i) = (∑i<DIM('a::executable_euclidean_space). f ((Basis_list::'a list) ! i))" apply (rule sum.reindex_cong[OF _ _ refl]) apply (auto intro!: inj_on_nth) by (metis Basis_list image_iff in_Basis_index_Basis_list index_less_size_conv length_Basis_list lessThan_iff) definition "eucl_of_list xs = (∑(x, i)←zip xs Basis_list. x *⇩R i)" lemma eucl_of_list_nth: assumes "length xs = DIM('a)" shows "eucl_of_list xs = (∑i<DIM('a::executable_euclidean_space). (xs ! i) *⇩R ((Basis_list::'a list) ! i))" by (auto simp: eucl_of_list_def sum_list_sum_nth length_Basis_list assms atLeast0LessThan) lemma eucl_of_list_inner: fixes i::"'a::executable_euclidean_space" assumes i: "i ∈ Basis" assumes l: "length xs = DIM('a)" shows "eucl_of_list xs ∙ i = xs ! (index Basis_list i)" by (simp add: eucl_of_list_nth[OF l] inner_sum_left assms inner_Basis nth_eq_iff_index sum.delta if_distrib cong: if_cong) lemma inner_eucl_of_list: fixes i::"'a::executable_euclidean_space" assumes i: "i ∈ Basis" assumes l: "length xs = DIM('a)" shows "i ∙ eucl_of_list xs = xs ! (index Basis_list i)" using eucl_of_list_inner[OF assms] by (auto simp: inner_commute) definition "list_of_eucl x = map ((∙) x) Basis_list" lemma index_Basis_list_nth[simp]: "i < DIM('a::executable_euclidean_space) ⟹ index Basis_list ((Basis_list::'a list) ! i) = i" by (simp add: index_nth_id) lemma list_of_eucl_eucl_of_list[simp]: "length xs = DIM('a::executable_euclidean_space) ⟹ list_of_eucl (eucl_of_list xs::'a) = xs" by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: nth_equalityI) lemma eucl_of_list_list_of_eucl[simp]: "eucl_of_list (list_of_eucl x) = x" by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: euclidean_eqI[where 'a='a]) lemma length_list_of_eucl[simp]: "length (list_of_eucl (x::'a::executable_euclidean_space)) = DIM('a)" by (auto simp: list_of_eucl_def) lemma list_of_eucl_nth[simp]: "n < DIM('a::executable_euclidean_space) ⟹ list_of_eucl x ! n = x ∙ (Basis_list ! n::'a)" by (auto simp: list_of_eucl_def) lemma nth_ge_len: "n ≥ length xs ⟹ xs ! n = [] ! (n - length xs)" by (induction xs arbitrary: n) auto lemma list_of_eucl_nth_if: "list_of_eucl x ! n = (if n < DIM('a::executable_euclidean_space) then x ∙ (Basis_list ! n::'a) else [] ! (n - DIM('a)))" apply (auto simp: list_of_eucl_def ) apply (subst nth_ge_len) apply auto done lemma list_of_eucl_eq_iff: "list_of_eucl (x::'a::executable_euclidean_space) = list_of_eucl (y::'b::executable_euclidean_space) ⟷ (DIM('a) = DIM('b) ∧ (∀i < DIM('b). x ∙ Basis_list ! i = y ∙ Basis_list ! i))" by (auto simp: list_eq_iff_nth_eq) lemma eucl_le_Basis_list_iff: "(x::'a::executable_euclidean_space) ≤ y ⟷ (∀i<DIM('a). x ∙ Basis_list ! i ≤ y ∙ Basis_list ! i)" apply (auto simp: eucl_le[where 'a='a]) subgoal for i subgoal by (auto dest!: spec[where x="index Basis_list i"]) done done lemma eucl_of_list_inj: "length xs = DIM('a::executable_euclidean_space) ⟹ length ys = DIM('a) ⟹ (eucl_of_list xs::'a) = eucl_of_list (ys) ⟹ xs = ys" apply (auto intro!: nth_equalityI simp: euclidean_eq_iff[where 'a="'a"] eucl_of_list_inner) using nth_Basis_list_in_Basis[where 'a="'a"] by fastforce lemma eucl_of_list_map_plus[simp]: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" shows "(eucl_of_list (map (λx. f x + g x) xs)::'a) = eucl_of_list (map f xs) + eucl_of_list (map g xs)" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) lemma eucl_of_list_map_uminus[simp]: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" shows "(eucl_of_list (map (λx. - f x) xs)::'a) = - eucl_of_list (map f xs)" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) lemma eucl_of_list_map_mult_left[simp]: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" shows "(eucl_of_list (map (λx. r * f x) xs)::'a) = r *⇩R eucl_of_list (map f xs)" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) lemma eucl_of_list_map_mult_right[simp]: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" shows "(eucl_of_list (map (λx. f x * r) xs)::'a) = r *⇩R eucl_of_list (map f xs)" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) lemma eucl_of_list_map_divide_right[simp]: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" shows "(eucl_of_list (map (λx. f x / r) xs)::'a) = eucl_of_list (map f xs) /⇩R r" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner divide_simps) lemma eucl_of_list_map_const[simp]: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" shows "(eucl_of_list (map (λx. c) xs)::'a) = c *⇩R One" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) lemma replicate_eq_list_of_eucl_zero: "replicate DIM('a::executable_euclidean_space) 0 = list_of_eucl (0::'a)" by (auto intro!: nth_equalityI) lemma eucl_of_list_append_zeroes[simp]: "eucl_of_list (xs @ replicate n 0) = eucl_of_list xs" unfolding eucl_of_list_def apply (auto simp: sum_list_sum_nth) apply (rule sum.mono_neutral_cong_right) by (auto simp: nth_append) lemma Basis_prodD: assumes "(i, j) ∈ Basis" shows "i ∈ Basis ∧ j = 0 ∨ i = 0 ∧ j ∈ Basis" using assms by (auto simp: Basis_prod_def) lemma eucl_of_list_take_DIM[simp]: assumes "d = DIM('b::executable_euclidean_space)" shows "(eucl_of_list (take d xs)::'b) = (eucl_of_list xs)" by (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list sum_list_sum_nth assms dest!: Basis_prodD) lemma eucl_of_list_eqI: assumes "take DIM('a) (xs @ replicate (DIM('a) - length xs) 0) = take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)" shows "eucl_of_list xs = (eucl_of_list ys::'a::executable_euclidean_space)" proof - have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ replicate (DIM('a) - length xs) 0))" by (simp add: ) also note assms also have "eucl_of_list (take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)) = (eucl_of_list ys::'a)" by simp finally show ?thesis . qed lemma eucl_of_list_replicate_zero[simp]: "eucl_of_list (replicate E 0) = 0" proof - have "eucl_of_list (replicate E 0) = (eucl_of_list (replicate E 0 @ replicate (DIM('a) - E) 0)::'a)" by simp also have "… = eucl_of_list (replicate DIM('a) 0)" apply (rule eucl_of_list_eqI) by (auto simp: min_def nth_append intro!: nth_equalityI) also have "… = 0" by (simp add: replicate_eq_list_of_eucl_zero) finally show ?thesis by simp qed lemma eucl_of_list_Nil[simp]: "eucl_of_list [] = 0" using eucl_of_list_replicate_zero[of 0] by simp lemma fst_eucl_of_list_prod: shows "fst (eucl_of_list xs::'b::executable_euclidean_space × _) = (eucl_of_list (take DIM('b) xs)::'b)" apply (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list dest!: Basis_prodD) apply (simp add: sum_list_sum_nth) apply (rule sum.mono_neutral_cong_right) subgoal by simp subgoal by auto subgoal by (auto simp: Basis_list_prod_def nth_append) subgoal by (auto simp: Basis_list_prod_def nth_append) done lemma index_zip_replicate1[simp]: "index (zip (replicate d a) bs) (a, b) = index bs b" if "d = length bs" using that by (induction bs arbitrary: d) auto lemma index_zip_replicate2[simp]: "index (zip as (replicate d b)) (a, b) = index as a" if "d = length as" using that by (induction as arbitrary: d) auto lemma index_Basis_list_prod[simp]: fixes a::"'a::executable_euclidean_space" and b::"'b::executable_euclidean_space" shows "a ∈ Basis ⟹ index Basis_list (a, 0::'b) = index Basis_list a" "b ∈ Basis ⟹ index Basis_list (0::'a, b) = DIM('a) + index Basis_list b" by (auto simp: Basis_list_prod_def index_append in_set_zip zip_replicate index_map_inj dest: spec[where x="index Basis_list a"]) lemma eucl_of_list_eq_takeI: assumes "(eucl_of_list (take DIM('a::executable_euclidean_space) xs)::'a) = x" shows "eucl_of_list xs = x" using eucl_of_list_take_DIM[OF refl, of xs, where 'b='a] assms by auto lemma eucl_of_list_inner_le: fixes i::"'a::executable_euclidean_space" assumes i: "i ∈ Basis" assumes l: "length xs ≥ DIM('a)" shows "eucl_of_list xs ∙ i = xs ! (index Basis_list i)" proof - have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ (replicate (DIM('a) - length xs) 0)))" by (rule eucl_of_list_eq_takeI) simp also have "… ∙ i = xs ! (index Basis_list i)" using assms by (subst eucl_of_list_inner) auto finally show ?thesis . qed lemma eucl_of_list_prod_if: assumes "length xs = DIM('a::executable_euclidean_space) + DIM('b::executable_euclidean_space)" shows "eucl_of_list xs = (eucl_of_list (take DIM('a) xs)::'a, eucl_of_list (drop DIM('a) xs)::'b)" apply (rule euclidean_eqI) using assms apply (auto simp: eucl_of_list_inner dest!: Basis_prodD) apply (subst eucl_of_list_inner_le) apply (auto simp: Basis_list_prod_def index_append in_set_zip) done lemma snd_eucl_of_list_prod: shows "snd (eucl_of_list xs::'b::executable_euclidean_space × 'c::executable_euclidean_space) = (eucl_of_list (drop DIM('b) xs)::'c)" proof (cases "length xs ≤ DIM('b)") case True then show ?thesis by (auto simp: eucl_of_list_inner eucl_of_list_def snd_sum_list dest!: Basis_prodD) (simp add: sum_list_sum_nth Basis_list_prod_def nth_append) next case False have "xs = take DIM('b) xs @ drop DIM('b) xs" by simp also have "eucl_of_list … = (eucl_of_list (… @ replicate (length xs - DIM('c)) 0)::'b × 'c)" by simp finally have "eucl_of_list xs = (eucl_of_list (xs @ replicate (DIM('b) + DIM('c) - length xs) 0)::'b × 'c)" by simp also have "… = eucl_of_list (take (DIM ('b × 'c)) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))" by (simp add: ) finally have *: "(eucl_of_list xs::'b×'c) = eucl_of_list (take DIM('b × 'c) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))" by simp show ?thesis apply (subst *) apply (subst eucl_of_list_prod_if) subgoal by simp subgoal apply simp apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric]) apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric]) apply (rule arg_cong[where f=eucl_of_list]) by (auto intro!: nth_equalityI simp: nth_append min_def split: if_splits) done qed lemma eucl_of_list_prod: shows "eucl_of_list xs = (eucl_of_list (take DIM('b) xs)::'b::executable_euclidean_space, eucl_of_list (drop DIM('b) xs)::'c::executable_euclidean_space)" using snd_eucl_of_list_prod[of xs, where 'b='b and 'c='c] using fst_eucl_of_list_prod[of xs, where 'b='b and 'a='c] by (auto simp del: snd_eucl_of_list_prod fst_eucl_of_list_prod simp add: prod_eq_iff) lemma eucl_of_list_real[simp]: "eucl_of_list [x] = (x::real)" by (auto simp: eucl_of_list_def Basis_list_real_def) lemma eucl_of_list_append[simp]: assumes "length xs = DIM('i::executable_euclidean_space)" assumes "length ys = DIM('j::executable_euclidean_space)" shows "eucl_of_list (xs @ ys) = (eucl_of_list xs::'i, eucl_of_list ys::'j)" using assms by (auto simp: eucl_of_list_prod) lemma list_allI: "(⋀x. x ∈ set xs ⟹ P x) ⟹ list_all P xs" by (auto simp: list_all_iff) lemma concat_map_nthI: assumes "⋀x y. x ∈ set xs ⟹ y ∈ set (f x) ⟹ P y" assumes "j < length (concat (map f xs))" shows "P (concat (map f xs) ! j)" proof - have "list_all P (concat (map f xs))" by (rule list_allI) (auto simp: assms) then show ?thesis by (auto simp: list_all_length assms) qed lemma map_nth_append1: assumes "length xs = d" shows "map ((!) (xs @ ys)) [0..<d] = xs" using assms by (auto simp: nth_append intro!: nth_equalityI) lemma map_nth_append2: assumes "length ys = d" shows "map ((!) (xs @ ys)) [length xs..<length xs + d] = ys" using assms by (auto simp: intro!: nth_equalityI) lemma length_map2 [simp]: "length (map2 f xs ys) = min (length xs) (length ys)" by simp lemma map2_nth [simp]: "map2 f xs ys ! n = f (xs ! n) (ys ! n)" if "n < length xs" "n < length ys" using that by simp lemma list_of_eucl_add: "list_of_eucl (x + y) = map2 (+) (list_of_eucl x) (list_of_eucl y)" by (auto intro!: nth_equalityI simp: inner_simps) lemma list_of_eucl_inj: "list_of_eucl z = list_of_eucl y ⟹ y = z" by (metis eucl_of_list_list_of_eucl) lemma length_Basis_list_pos[simp]: "length Basis_list > 0" by (metis length_pos_if_in_set Basis_list SOME_Basis) lemma Basis_list_nth_nonzero: "i < length (Basis_list::'a::executable_euclidean_space list) ⟹ (Basis_list::'a list) ! i ≠ 0" by (auto dest!: nth_mem simp: nonzero_Basis) lemma nth_Basis_list_prod: "i < DIM('a) + DIM('b) ⟹ (Basis_list::('a::executable_euclidean_space × 'b::executable_euclidean_space) list) ! i = (if i < DIM('a) then (Basis_list ! i, 0) else (0, Basis_list ! (i - DIM('a))))" by (auto simp: Basis_list_nth_nonzero prod_eq_iff Basis_list_prod_def nth_append not_less) lemma eucl_of_list_if: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs" shows "eucl_of_list (map (λxa. if xa = x then 1 else 0) (xs::nat list)) = (if x ∈ set xs then Basis_list ! index xs x else 0::'a)" by (rule euclidean_eqI) (auto simp: eucl_of_list_inner inner_Basis index_nth_id) lemma take_append_take_minus_idem: "take n XS @ map ((!) XS) [n..<length XS] = XS" by (auto intro!: nth_equalityI simp: nth_append min_def) lemma sum_list_Basis_list[simp]: "sum_list (map f Basis_list) = (∑b∈Basis. f b)" by (subst sum_list_distinct_conv_sum_set) (auto simp: Basis_list distinct_Basis_list) lemma hd_Basis_list[simp]: "hd Basis_list ∈ Basis" unfolding Basis_list[symmetric] by (rule hd_in_set) (auto simp: set_empty[symmetric]) definition "inner_lv_rel a b = sum_list (map2 (*) a b)" lemma eucl_of_list_inner_eq: "(eucl_of_list xs::'a) ∙ eucl_of_list ys = inner_lv_rel xs ys" if "length xs = DIM('a::executable_euclidean_space)" "length ys = DIM('a)" using that by (subst euclidean_inner[abs_def], subst sum_list_Basis_list[symmetric]) (auto simp: eucl_of_list_inner sum_list_sum_nth index_nth_id inner_lv_rel_def) lemma euclidean_vec_componentwise: "(∑(xa::'a::euclidean_space^'b::finite)∈Basis. f xa) = (∑a∈Basis. (∑b::'b∈UNIV. f (axis b a)))" apply (auto simp: Basis_vec_def) apply (subst sum.swap) apply (subst sum.Union_disjoint) apply auto apply (simp add: axis_eq_axis nonzero_Basis) apply (simp add: axis_eq_axis nonzero_Basis) apply (subst sum.reindex) apply (auto intro!: injI) subgoal apply (auto simp: set_eq_iff) by (metis (full_types) all_not_in_conv inner_axis_axis inner_eq_zero_iff nonempty_Basis nonzero_Basis) apply (rule sum.cong[OF refl]) apply (auto ) apply (rule sum.reindex_cong[OF _ _ refl]) apply (auto intro!: inj_onI) using axis_eq_axis by blast lemma vec_nth_inner_scaleR_craziness: "f (x $ i ∙ j) *⇩R j = (∑xa∈UNIV. f (x $ xa ∙ j) *⇩R axis xa j) $ i" by vector (auto simp: axis_def if_distrib scaleR_vec_def sum.delta' cong: if_cong) instantiation vec :: ("{executable_euclidean_space}", enum) executable_euclidean_space begin definition Basis_list_vec :: "('a, 'b) vec list" where "Basis_list_vec = concat (map (λn. map (axis n) Basis_list) enum_class.enum)" definition eucl_down_vec :: "int ⇒ ('a, 'b) vec ⇒ ('a, 'b) vec" where "eucl_down_vec p x = (χ i. eucl_down p (x $ i))" definition eucl_truncate_down_vec :: "nat ⇒ ('a, 'b) vec ⇒ ('a, 'b) vec" where "eucl_truncate_down_vec p x = (χ i. eucl_truncate_down p (x $ i))" definition eucl_truncate_up_vec :: "nat ⇒ ('a, 'b) vec ⇒ ('a, 'b) vec" where "eucl_truncate_up_vec p x = (χ i. eucl_truncate_up p (x $ i))" instance proof show *: "set (Basis_list::('a, 'b) vec list) = Basis" unfolding Basis_list_vec_def Basis_vec_def apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map Basis_vec_def intro!: distinct_concat inj_onI split: if_splits) apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map enum_distinct UNIV_enum[symmetric] intro!: distinct_concat inj_onI split: if_splits) done have "length (Basis_list::('a, 'b) vec list) = CARD('b) * DIM('a)" by (auto simp: Basis_list_vec_def length_concat o_def enum_distinct sum_list_distinct_conv_sum_set UNIV_enum[symmetric]) then show "distinct (Basis_list::('a, 'b) vec list)" using * by (auto intro!: card_distinct) qed (simp_all only: vector_cart[symmetric] vec_eq_iff eucl_down_vec_def eucl_down_def eucl_truncate_down_vec_def eucl_truncate_down_def eucl_truncate_up_vec_def eucl_truncate_up_def, auto simp: euclidean_vec_componentwise inner_axis Basis_list_vec_def vec_nth_inner_scaleR_craziness intro!: sum.cong[OF refl]) end lemma concat_same_lengths_nth: assumes "⋀xs. xs ∈ set XS ⟹ length xs = N" assumes "i < length XS * N" "N > 0" shows "concat XS ! i = XS ! (i div N) ! (i mod N)" using assms apply (induction XS arbitrary: i) apply (auto simp: nth_append nth_Cons split: nat.splits) apply (simp add: div_eq_0_iff) by (metis Suc_inject div_geq mod_geq) lemma concat_map_map_index: shows "concat (map (λn. map (f n) xs) ys) = map (λi. f (ys ! (i div length xs)) (xs ! (i mod length xs))) [0..<length xs * length ys]" apply (auto intro!: nth_equalityI simp: length_concat o_def sum_list_sum_nth) apply (subst concat_same_lengths_nth) apply (auto simp: ) apply (subst nth_map_upt) apply (auto simp: ac_simps) apply (subst nth_map) apply (metis div_eq_0_iff div_mult2_eq mult.commute mult_0 not_less0) apply (subst nth_map) subgoal for i using gr_implies_not_zero by fastforce subgoal by simp done lemma sum_list_zip_map: assumes "distinct xs" shows "(∑(x, y)←zip xs (map g xs). f x y) = (∑x∈set xs. f x (g x))" by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta' in_set_zip in_set_conv_nth inj_on_convol_ident intro!: sum.reindex_cong[where l="λx. (x, g x)"]) lemma sum_list_zip_map_of: assumes "distinct bs" assumes "length xs = length bs" shows "(∑(x, y)←zip xs bs. f x y) = (∑x∈set bs. f (the (map_of (zip bs xs) x)) x)" proof - have "(∑(x, y)←zip xs bs. f x y) = (∑(y, x)←zip bs xs. f x y)" by (subst zip_commute) (auto simp: o_def split_beta') also have "… = (∑(x, y)←zip bs (map (the o map_of (zip bs xs)) bs). f y x)" proof (rule arg_cong, rule map_cong) have "xs = (map (the ∘ map_of (zip bs xs)) bs)" using assms by (auto intro!: nth_equalityI simp: map_nth map_of_zip_nth) then show "zip bs xs = zip bs (map (the ∘ map_of (zip bs xs)) bs)" by simp qed auto also have "… = (∑x∈set bs. f (the (map_of (zip bs xs) x)) x)" using assms(1) by (subst sum_list_zip_map) (auto simp: o_def) finally show ?thesis . qed lemma vec_nth_matrix: "vec_nth (vec_nth (matrix y) i) j = vec_nth (y (axis j 1)) i" unfolding matrix_def by simp lemma matrix_eqI: assumes "⋀x. x ∈ Basis ⟹ A *v x = B *v x" shows "(A::real^'n^'n) = B" apply vector using assms apply (auto simp: Basis_vec_def) by (metis cart_eq_inner_axis matrix_vector_mul_component) lemma matrix_columnI: assumes "⋀i. column i A = column i B" shows "(A::real^'n^'n) = B" using assms apply vector apply (auto simp: column_def) apply vector by (metis iso_tuple_UNIV_I vec_lambda_inject) lemma vec_nth_Basis: fixes x::"real^'n" shows "x ∈ Basis ⟹ vec_nth x i = (if x = axis i 1 then 1 else 0)" apply (auto simp: Basis_vec_def) by (metis cart_eq_inner_axis inner_axis_axis) lemma vec_nth_eucl_of_list_eq: "length M = CARD('n) ⟹ vec_nth (eucl_of_list M::real^'n::enum) i = M ! index Basis_list (axis i (1::real))" apply (auto simp: eucl_of_list_def) apply (subst sum_list_zip_map_of) apply (auto intro!: distinct_zipI2 simp: split_beta') apply (subst sum.cong[OF refl]) apply (subst vec_nth_Basis) apply (force simp: set_zip) apply (rule refl) apply (auto simp: if_distrib sum.delta cong: if_cong) subgoal apply (cases "map_of (zip Basis_list M) (axis i 1::real^'n::enum)") subgoal premises prems proof - have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum) set)" using prems by (auto simp: in_set_zip) then show ?thesis using prems by (subst (asm) map_of_eq_None_iff) simp qed subgoal for a apply (auto simp: in_set_zip) subgoal premises prems for n by (metis DIM_cart DIM_real index_Basis_list_nth mult.right_neutral prems(2) prems(3)) done done done lemma index_Basis_list_axis1: "index Basis_list (axis i (1::real)) = index enum_class.enum i" apply (auto simp: Basis_list_vec_def Basis_list_real_def ) apply (subst index_map_inj) by (auto intro!: injI simp: axis_eq_axis) lemma vec_nth_eq_list_of_eucl1: "(vec_nth (M::real^'n::enum) i) = list_of_eucl M ! (index enum_class.enum i)" apply (subst eucl_of_list_list_of_eucl[of M, symmetric]) apply (subst vec_nth_eucl_of_list_eq) unfolding index_Basis_list_axis1 by auto lemma enum_3[simp]: "(enum_class.enum::3 list) = [0, 1, 2]" by code_simp+ lemma three_eq_zero: "(3::3) = 0" by simp lemma forall_3': "(∀i::3. P i) ⟷ P 0 ∧ P 1 ∧ P 2" using forall_3 three_eq_zero by auto lemma euclidean_eq_list_of_euclI: "x = y" if "list_of_eucl x = list_of_eucl y" using that by (metis eucl_of_list_list_of_eucl) lemma axis_one_neq_zero[simp]: "axis xa (1::'a::zero_neq_one) ≠ 0" by (auto simp: axis_def vec_eq_iff) lemma eucl_of_list_vec_nth3[simp]: "(eucl_of_list [g, h, i]::real^3) $ 0 = g" "(eucl_of_list [g, h, i]::real^3) $ 1 = h" "(eucl_of_list [g, h, i]::real^3) $ 2 = i" "(eucl_of_list [g, h, i]::real^3) $ 3 = g" by (auto simp: cart_eq_inner_axis eucl_of_list_inner vec_nth_eq_list_of_eucl1 index_Basis_list_axis1) type_synonym R3 = "real*real*real" lemma Basis_list_R3: "Basis_list = [(1,0,0), (0, 1, 0), (0, 0, 1)::R3]" by (auto simp: Basis_list_prod_def Basis_list_real_def zero_prod_def) lemma Basis_list_vec3: "Basis_list = [axis 0 1::real^3, axis 1 1, axis 2 1]" by (auto simp: Basis_list_vec_def Basis_list_real_def) lemma eucl_of_list3[simp]: "eucl_of_list [a, b, c] = (a, b, c)" by (auto simp: eucl_of_list_inner Basis_list_vec_def zero_prod_def Basis_prod_def Basis_list_vec3 Basis_list_R3 intro!: euclidean_eqI[where 'a=R3]) subsection ‹Bounded Linear Functions› subsection ‹bounded linear functions› locale blinfun_syntax begin no_notation vec_nth (infixl "$" 90) notation blinfun_apply (infixl "$" 999) end lemma bounded_linear_via_derivative: fixes f::"'a::real_normed_vector ⇒ 'b::euclidean_space ⇒⇩L 'c::real_normed_vector" ― ‹TODO: generalize?› assumes "⋀i. ((λx. blinfun_apply (f x) i) has_derivative (λx. f' y x i)) (at y)" shows "bounded_linear (f' y x)" proof - interpret linear "f' y x" proof (unfold_locales, goal_cases) case (1 v w) from has_derivative_unique[OF assms[of "v + w", unfolded blinfun.bilinear_simps] has_derivative_add[OF assms[of v] assms[of w]], THEN fun_cong, of x] show ?case . next case (2 r v) from has_derivative_unique[OF assms[of "r *⇩R v", unfolded blinfun.bilinear_simps] has_derivative_scaleR_right[OF assms[of v], of r], THEN fun_cong, of x] show ?case . qed let ?bnd = "∑i∈Basis. norm (f' y x i)" { fix v have "f' y x v = (∑i∈Basis. (v ∙ i) *⇩R f' y x i)" by (subst euclidean_representation[symmetric]) (simp add: sum scaleR) also have "norm … ≤ norm v * ?bnd" by (auto intro!: order.trans[OF norm_sum] sum_mono mult_right_mono simp: sum_distrib_left Basis_le_norm) finally have "norm (f' y x v) ≤ norm v * ?bnd" . } then show ?thesis by unfold_locales auto qed definition blinfun_scaleR::"('a::real_normed_vector ⇒⇩L real) ⇒ 'b::real_normed_vector ⇒ ('a ⇒⇩L 'b)" where "blinfun_scaleR a b = blinfun_scaleR_left b o⇩L a" lemma blinfun_scaleR_transfer[transfer_rule]: "rel_fun (pcr_blinfun (=) (=)) (rel_fun (=) (pcr_blinfun (=) (=))) (λa b c. a c *⇩R b) blinfun_scaleR" by (auto simp: blinfun_scaleR_def rel_fun_def pcr_blinfun_def cr_blinfun_def OO_def) lemma blinfun_scaleR_rep_eq[simp]: "blinfun_scaleR a b c = a c *⇩R b" by (simp add: blinfun_scaleR_def) lemma bounded_linear_blinfun_scaleR: "bounded_linear (blinfun_scaleR a)" unfolding blinfun_scaleR_def[abs_def] by (auto intro!: bounded_linear_intros) lemma blinfun_scaleR_has_derivative[derivative_intros]: assumes "(f has_derivative f') (at x within s)" shows "((λx. blinfun_scaleR a (f x)) has_derivative (λx. blinfun_scaleR a (f' x))) (at x within s)" using bounded_linear_blinfun_scaleR assms by (rule bounded_linear.has_derivative) lemma blinfun_componentwise: fixes f::"'a::real_normed_vector ⇒ 'b::euclidean_space ⇒⇩L 'c::real_normed_vector" shows "f = (λx. ∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))" by (auto intro!: blinfun_eqI simp: blinfun.sum_left euclidean_representation blinfun.scaleR_right[symmetric] blinfun.sum_right[symmetric]) lemma blinfun_has_derivative_componentwiseI: fixes f::"'a::real_normed_vector ⇒ 'b::euclidean_space ⇒⇩L 'c::real_normed_vector" assumes "⋀i. i ∈ Basis ⟹ ((λx. f x i) has_derivative blinfun_apply (f' i)) (at x)" shows "(f has_derivative (λx. ∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f' i x))) (at x)" by (subst blinfun_componentwise) (force intro: derivative_eq_intros assms simp: blinfun.bilinear_simps) lemma has_derivative_BlinfunI: fixes f::"'a::real_normed_vector ⇒ 'b::euclidean_space ⇒⇩L 'c::real_normed_vector" assumes "⋀i. ((λx. f x i) has_derivative (λx. f' y x i)) (at y)" shows "(f has_derivative (λx. Blinfun (f' y x))) (at y)" proof - have 1: "f = (λx. ∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))" by (rule blinfun_componentwise) moreover have 2: "(… has_derivative (λx. ∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i))) (at y)" by (force intro: assms derivative_eq_intros) moreover interpret f': bounded_linear "f' y x" for x by (rule bounded_linear_via_derivative) (rule assms) have 3: "(∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i)) i = f' y x i" for x i by (auto simp: if_distrib if_distribR blinfun.bilinear_simps f'.scaleR[symmetric] f'.sum[symmetric] euclidean_representation intro!: blinfun_euclidean_eqI) have 4: "blinfun_apply (Blinfun (f' y x)) = f' y x" for x apply (subst bounded_linear_Blinfun_apply) subgoal by unfold_locales subgoal by simp done show ?thesis apply (subst 1) apply (rule 2[THEN has_derivative_eq_rhs]) apply (rule ext) apply (rule blinfun_eqI) apply (subst 3) apply (subst 4) apply (rule refl) done qed lemma has_derivative_Blinfun: assumes "(f has_derivative f') F" shows "(f has_derivative Blinfun f') F" using assms by (subst bounded_linear_Blinfun_apply) auto lift_definition flip_blinfun:: "('a::real_normed_vector ⇒⇩L 'b::real_normed_vector ⇒⇩L 'c::real_normed_vector) ⇒ 'b ⇒⇩L 'a ⇒⇩L 'c" is "λf x y. f y x" using bounded_bilinear.bounded_linear_left bounded_bilinear.bounded_linear_right bounded_bilinear.flip by auto lemma flip_blinfun_apply[simp]: "flip_blinfun f a b = f b a" by transfer simp lemma le_norm_blinfun: shows "norm (blinfun_apply f x) / norm x ≤ norm f" by transfer (rule le_onorm) lemma norm_flip_blinfun[simp]: "norm (flip_blinfun x) = norm x" (is "?l = ?r") proof (rule antisym) from order_trans[OF norm_blinfun, OF mult_right_mono, OF norm_blinfun, OF norm_ge_zero, of x] show "?l ≤ ?r" by (auto intro!: norm_blinfun_bound simp: ac_simps) have "norm (x a b) ≤ norm (flip_blinfun x) * norm a * norm b" for a b proof - have "norm (x a b) / norm a ≤ norm (flip_blinfun x b)" by (rule order_trans[OF _ le_norm_blinfun]) auto also have "… ≤ norm (flip_blinfun x) * norm b" by (rule norm_blinfun) finally show ?thesis by (auto simp add: divide_simps blinfun.bilinear_simps algebra_simps split: if_split_asm) qed then show "?r ≤ ?l" by (auto intro!: norm_blinfun_bound) qed lemma bounded_linear_flip_blinfun[bounded_linear]: "bounded_linear flip_blinfun" by unfold_locales (auto simp: blinfun.bilinear_simps intro!: blinfun_eqI exI[where x=1]) lemma dist_swap2_swap2[simp]: "dist (flip_blinfun f) (flip_blinfun g) = dist f g" by (metis (no_types) bounded_linear_flip_blinfun dist_blinfun_def linear_simps(2) norm_flip_blinfun) context includes blinfun.lifting begin lift_definition blinfun_of_vmatrix::"(real^'m^'n) ⇒ ((real^('m::finite)) ⇒⇩L (real^('n::finite)))" is "matrix_vector_mult:: ((real, 'm) vec, 'n) vec ⇒ ((real, 'm) vec ⇒ (real, 'n) vec)" unfolding linear_linear by (rule matrix_vector_mul_linear) lemma matrix_blinfun_of_vmatrix[simp]: "matrix (blinfun_of_vmatrix M) = M" apply vector apply (auto simp: matrix_def) apply transfer by (metis cart_eq_inner_axis matrix_vector_mul_component) end lemma blinfun_apply_componentwise: "B = (∑i∈Basis. blinfun_scaleR (blinfun_inner_left i) (blinfun_apply B i))" using blinfun_componentwise[of "λx. B", unfolded fun_eq_iff] by blast lemma blinfun_apply_eq_sum: assumes [simp]: "length v = CARD('n)" shows "blinfun_apply (B::(real^'n::enum)⇒⇩L(real^'m::enum)) (eucl_of_list v) = (∑i<CARD('m). ∑j<CARD('n). ((B (Basis_list ! j) ∙ Basis_list ! i) * v ! j) *⇩R (Basis_list ! i))" apply (subst blinfun_apply_componentwise[of B]) apply (auto intro!: euclidean_eqI[where 'a="(real,'m) vec"] simp: blinfun.bilinear_simps eucl_of_list_inner inner_sum_left inner_Basis if_distrib sum_Basis_sum_nth_Basis_list nth_eq_iff_index if_distribR cong: if_cong) apply (subst sum.swap) by (auto simp: sum.delta algebra_simps) lemma in_square_lemma[intro, simp]: "x * C + y < D * C" if "x < D" "y < C" for x::nat proof - have "x * C + y < (D - 1) * C + C" apply (rule add_le_less_mono) apply (rule mult_right_mono) using that by auto also have "… ≤ D * C" using that by (auto simp: algebra_simps) finally show ?thesis . qed lemma less_square_imp_div_less[intro, simp]: "i < E * D ⟹ i div E < D" for i::nat by (metis div_eq_0_iff div_mult2_eq gr_implies_not0 mult_not_zero) lemma in_square_lemma'[intro, simp]: "i < L ⟹ n < N ⟹ i * N + n < N * L" for i n::nat by (metis in_square_lemma mult.commute) lemma distinct_nth_eq_iff: "distinct xs ⟹ x < length xs ⟹ y < length xs ⟹ xs ! x = xs ! y ⟷ x = y" by (drule inj_on_nth[where I="{..<length xs}"]) (auto simp: inj_onD) lemma index_Basis_list_axis2: "index Basis_list (axis (j::'j::enum) (axis (i::'i::enum) (1::real))) = (index enum_class.enum j) * CARD('i) + index enum_class.enum i" apply (auto simp: Basis_list_vec_def Basis_list_real_def o_def) apply (subst concat_map_map_index) unfolding card_UNIV_length_enum[symmetric] subgoal proof - have index_less_cardi: "index enum_class.enum k < CARD('i)" for k::'i by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum) have index_less_cardj: "index enum_class.enum k < CARD('j)" for k::'j by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum) have *: "axis j (axis i 1) = (λi. axis (enum_class.enum ! (i div CARD('i))) (axis (enum_class.enum ! (i mod CARD('i))) 1)) ((index enum_class.enum j) * CARD('i) + index enum_class.enum i)" by (auto simp: index_less_cardi enum_UNIV) note less=in_square_lemma[OF index_less_cardj index_less_cardi, of j i] show ?thesis apply (subst *) apply (subst index_map_inj_on[where S="{..<CARD('j)*CARD('i)}"]) subgoal apply (auto intro!: inj_onI simp: axis_eq_axis ) apply (subst (asm) distinct_nth_eq_iff) apply (auto simp: enum_distinct card_UNIV_length_enum) subgoal for x y using gr_implies_not0 by fastforce subgoal for x y using gr_implies_not0 by fastforce subgoal for x y apply (drule inj_onD[OF inj_on_nth[OF enum_distinct[where 'a='j], where I = "{..<CARD('j)}"], rotated]) apply (auto simp: card_UNIV_length_enum mult.commute) subgoal by (metis mod_mult_div_eq) done done subgoal using less by (auto simp: ) subgoal by (auto simp: card_UNIV_length_enum ac_simps) subgoal apply (subst index_upt) subgoal using less by auto subgoal using less by (auto simp: ac_simps) subgoal using less by auto done done qed done lemma vec_nth_Basis2: fixes x::"real^'n^'m" shows "x ∈ Basis ⟹ vec_nth (vec_nth x i) j = ((if x = axis i (axis j 1) then 1 else 0))" by (auto simp: Basis_vec_def axis_def) lemma vec_nth_eucl_of_list_eq2: "length M = CARD('n) * CARD('m) ⟹ vec_nth (vec_nth (eucl_of_list M::real^'n::enum^'m::enum) i) j = M ! index Basis_list (axis i (axis j (1::real)))" apply (auto simp: eucl_of_list_def) apply (subst sum_list_zip_map_of) apply (auto intro!: distinct_zipI2 simp: split_beta') apply (subst sum.cong[OF refl]) apply (subst vec_nth_Basis2) apply (force simp: set_zip) apply (rule refl) apply (auto simp: if_distrib sum.delta cong: if_cong) subgoal apply (cases "map_of (zip Basis_list M) (axis i (axis j 1)::real^'n::enum^'m::enum)") subgoal premises prems proof - have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum^'m::enum) set)" using prems by (auto simp: in_set_zip) then show ?thesis using prems by (subst (asm) map_of_eq_None_iff) auto qed subgoal for a apply (auto simp: in_set_zip) subgoal premises prems for n proof - have "n < card (Basis::(real^'n::_^'m::_) set)" by (simp add: prems(4)) then show ?thesis by (metis index_Basis_list_nth prems(2)) qed done done done lemma vec_nth_eq_list_of_eucl2: "vec_nth (vec_nth (M::real^'n::enum^'m::enum) i) j = list_of_eucl M ! (index enum_class.enum i * CARD('n) + index enum_class.enum j)" apply (subst eucl_of_list_list_of_eucl[of M, symmetric]) apply (subst vec_nth_eucl_of_list_eq2) unfolding index_Basis_list_axis2 by auto theorem eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list: assumes "length M = CARD('n) * CARD('m)" assumes "length v = CARD('n)" shows "(eucl_of_list M::real^'n::enum^'m::enum) *v eucl_of_list v = (∑i<CARD('m). (∑j<CARD('n). M ! (i * CARD('n) + j) * v ! j) *⇩R Basis_list ! i)" apply (vector matrix_vector_mult_def) apply (auto simp: ) apply (subst vec_nth_eucl_of_list_eq2) apply (auto simp: assms) apply (subst vec_nth_eucl_of_list_eq) apply (auto simp: assms index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_Basis sum.delta nth_eq_iff_index if_distrib cong: if_cong) subgoal for i apply (rule sum.reindex_cong[where l="nth enum_class.enum"]) apply (auto simp: enum_distinct card_UNIV_length_enum distinct_nth_eq_iff intro!: inj_onI) apply (rule image_eqI[OF ]) apply (rule nth_index[symmetric]) apply (auto simp: enum_UNIV) by (auto simp: algebra_simps enum_UNIV enum_distinct index_nth_id) subgoal for i using index_less[of i "enum_class.enum" "CARD('n)"] by (auto simp: enum_UNIV card_UNIV_length_enum) done lemma index_enum_less[intro, simp]: "index enum_class.enum (i::'n::enum) < CARD('n)" by (auto intro!: index_less simp: enum_UNIV card_UNIV_length_enum) lemmas [intro, simp] = enum_distinct lemmas [simp] = card_UNIV_length_enum[symmetric] enum_UNIV lemma sum_index_enum_eq: "(∑(k::'n::enum)∈UNIV. f (index enum_class.enum k)) = (∑i<CARD('n). f i)" by (rule sum.reindex_cong[where l="nth enum_class.enum"]) (force intro!: inj_onI simp: distinct_nth_eq_iff index_nth_id)+ end
section ‹Affine Form› theory Affine_Form imports "HOL-Analysis.Multivariate_Analysis" "HOL-Library.List_Permutation" Affine_Arithmetic_Auxiliarities Executable_Euclidean_Space begin subsection ‹Auxiliary developments› lemma sum_list_mono: fixes xs ys::"'a::ordered_ab_group_add list" shows "length xs = length ys ⟹ (⋀x y. (x, y) ∈ set (zip xs ys) ⟹ x ≤ y) ⟹ sum_list xs ≤ sum_list ys" by (induct xs ys rule: list_induct2) (auto simp: algebra_simps intro: add_mono) lemma fixes xs::"'a::ordered_comm_monoid_add list" shows sum_list_nonneg: "(⋀x. x ∈ set xs ⟹ x ≥ 0) ⟹ sum_list xs ≥ 0" by (induct xs) (auto intro!: add_nonneg_nonneg) lemma map_filter: "map f (filter (λx. P (f x)) xs) = filter P (map f xs)" by (induct xs) simp_all lemma map_of_zip_upto2_length_eq_nth: assumes "distinct B" assumes "i < length B" shows "(map_of (zip B [0..<length B]) (B ! i)) = Some i" proof - have "length [0..<length B] = length B" by simp from map_of_zip_is_Some[OF this, of i] assms have "map_of (zip B [0..<length B]) (B ! i) = Some i" using assms by (auto simp: in_set_zip) thus ?thesis by simp qed lemma distinct_map_fst_snd_eqD: "distinct (map fst xs) ⟹ (i, a) ∈ set xs ⟹ (i, b) ∈ set xs ⟹ a = b" by (metis (lifting) map_of_is_SomeI option.inject) lemma length_filter_snd_zip: "length ys = length xs ⟹ length (filter (p ∘ snd) (zip ys xs)) = length (filter p xs)" by (induct ys xs rule: list_induct2) (auto ) lemma filter_snd_nth: "length ys = length xs ⟹ n < length (filter p xs) ⟹ snd (filter (p ∘ snd) (zip ys xs) ! n) = filter p xs ! n" by (induct ys xs arbitrary: n rule: list_induct2) (auto simp: o_def nth_Cons split: nat.split) lemma distinct_map_snd_fst_eqD: "distinct (map snd xs) ⟹ (i, a) ∈ set xs ⟹ (j, a) ∈ set xs ⟹ i = j" by (metis Pair_inject inj_on_contraD snd_conv distinct_map) lemma map_of_mapk_inj_on_SomeI: "inj_on f (fst ` (set t)) ⟹ map_of t k = Some x ⟹ map_of (map (case_prod (λk. Pair (f k))) t) (f k) = Some x" by (induct t) (auto simp add: inj_on_def dest!: map_of_SomeD split: if_split_asm) lemma map_abs_nonneg[simp]: fixes xs::"'a::ordered_ab_group_add_abs list" shows "list_all (λx. x ≥ 0) xs ⟹ map abs xs = xs" by (induct xs) auto lemma the_inv_into_image_eq: "inj_on f A ⟹ Y ⊆ f ` A ⟹ the_inv_into A f ` Y = f -` Y ∩ A" using f_the_inv_into_f the_inv_into_f_f[where f = f and A = A] by force lemma image_fst_zip: "length ys = length xs ⟹ fst ` set (zip ys xs) = set ys" by (metis dom_map_of_conv_image_fst dom_map_of_zip) lemma inj_on_fst_set_zip_distinct[simp]: "distinct xs ⟹ length xs = length ys ⟹ inj_on fst (set (zip xs ys))" by (force simp add: in_set_zip distinct_conv_nth intro!: inj_onI) lemma mem_greaterThanLessThan_absI: fixes x::real assumes "abs x < 1" shows "x ∈ {-1 <..< 1}" using assms by (auto simp: abs_real_def split: if_split_asm) lemma minus_one_less_divideI: "b > 0 ⟹ -b < a ⟹ -1 < a / (b::real)" by (auto simp: field_simps) lemma divide_less_oneI: "b > 0 ⟹ b > a ⟹ a / (b::real) < 1" by (auto simp: field_simps) lemma closed_segment_real: fixes a b::real shows "closed_segment a b = (if a ≤ b then {a .. b} else {b .. a})" (is "_ = ?if") proof safe fix x assume "x ∈ closed_segment a b" from segment_bound[OF this] show "x ∈ ?if" by (auto simp: abs_real_def split: if_split_asm) next fix x assume "x ∈ ?if" thus "x ∈ closed_segment a b" by (auto simp: closed_segment_def intro!: exI[where x="(x - a)/(b - a)"] simp: divide_simps algebra_simps) qed subsection ‹Partial Deviations› typedef (overloaded) 'a pdevs = "{x::nat ⇒ 'a::zero. finite {i. x i ≠ 0}}" ― ‹TODO: unify with polynomials› morphisms pdevs_apply Abs_pdev by (auto intro!: exI[where x="λx. 0"]) setup_lifting type_definition_pdevs lemma pdevs_eqI: "(⋀i. pdevs_apply x i = pdevs_apply y i) ⟹ x = y" by transfer auto definition pdevs_val :: "(nat ⇒ real) ⇒ 'a::real_normed_vector pdevs ⇒ 'a" where "pdevs_val e x = (∑i. e i *⇩R pdevs_apply x i)" definition valuate:: "((nat ⇒ real) ⇒ 'a) ⇒ 'a set" where "valuate x = x ` (UNIV → {-1 .. 1})" lemma valuate_ex: "x ∈ valuate f ⟷ (∃e. (∀i. e i ∈ {-1 .. 1}) ∧ x = f e)" unfolding valuate_def by (auto simp add: valuate_def Pi_iff) blast instantiation pdevs :: (equal) equal begin definition equal_pdevs::"'a pdevs ⇒ 'a pdevs ⇒ bool" where "equal_pdevs a b ⟷ a = b" instance proof qed (simp add: equal_pdevs_def) end subsection ‹Affine Forms› text ‹The data structure of affine forms represents particular sets, zonotopes› type_synonym 'a aform = "'a × 'a pdevs" subsection ‹Evaluation, Range, Joint Range› definition aform_val :: "(nat ⇒ real) ⇒ 'a::real_normed_vector aform ⇒ 'a" where "aform_val e X = fst X + pdevs_val e (snd X)" definition Affine :: "'a::real_normed_vector aform ⇒ 'a set" where "Affine X = valuate (λe. aform_val e X)" definition Joints :: "'a::real_normed_vector aform list ⇒ 'a list set" where "Joints XS = valuate (λe. map (aform_val e) XS)" lemma Joints_nthE: assumes "zs ∈ Joints ZS" obtains e where "⋀i. i < length zs ⟹ zs ! i = aform_val e (ZS ! i)" "⋀i. e i ∈ {-1..1}" using assms by atomize_elim (auto simp: Joints_def Pi_iff valuate_ex) lemma Joints_mapE: assumes "ys ∈ Joints YS" obtains e where "ys = map (λx. aform_val e x) YS" "⋀i. e i ∈ {-1 .. 1}" using assms by (force simp: Joints_def valuate_def) lemma zipped_subset_mapped_Elem: assumes "xs = map (aform_val e) XS" assumes e: "⋀i. e i ∈ {-1 .. 1}" assumes [simp]: "length xs = length XS" assumes [simp]: "length ys = length YS" assumes "set (zip ys YS) ⊆ set (zip xs XS)" shows "ys = map (aform_val e) YS" proof - from assms have ys: "⋀i. i < length xs ⟹ xs ! i = aform_val e (XS ! i)" by auto from assms have set_eq: "{(ys ! i, YS ! i) |i. i < length ys ∧ i < length YS} ⊆ {(xs ! i, XS ! i) |i. i < length xs ∧ i < length XS}" using assms(2) by (auto simp: set_zip) hence "∀i<length YS. ∃j<length XS. ys ! i = xs ! j ∧ YS ! i = XS ! j" by auto then obtain j where j: "⋀i. i < length YS ⟹ ys ! i = xs ! (j i)" "⋀i. i < length YS ⟹ YS ! i = XS ! (j i)" "⋀i. i < length YS ⟹ j i < length XS" by metis show ?thesis using assms by (auto simp: Joints_def j ys intro!: exI[where x=e] nth_equalityI) qed lemma Joints_set_zip_subset: assumes "xs ∈ Joints XS" assumes "length xs = length XS" assumes "length ys = length YS" assumes "set (zip ys YS) ⊆ set (zip xs XS)" shows "ys ∈ Joints YS" proof - from Joints_mapE assms obtain e where ys: "xs = map (λx. aform_val e x) XS" and e: "⋀i. e i ∈ {-1 .. 1}" by blast show "ys ∈ Joints YS" using e zipped_subset_mapped_Elem[OF ys e assms(2-4)] by (auto simp: Joints_def valuate_def intro!: exI[where x=e]) qed lemma Joints_set_zip: assumes "ys ∈ Joints YS" assumes "length xs = length XS" assumes "length YS = length XS" assumes sets_eq: "set (zip xs XS) = set (zip ys YS)" shows "xs ∈ Joints XS" proof - from assms have "length ys = length YS" by (auto simp: Joints_def valuate_def) from assms(1) this assms(2) show ?thesis by (rule Joints_set_zip_subset) (simp add: assms) qed definition Joints2 :: "'a::real_normed_vector aform list ⇒'b::real_normed_vector aform ⇒ ('a list × 'b) set" where "Joints2 XS Y = valuate (λe. (map (aform_val e) XS, aform_val e Y))" lemma Joints2E: assumes "zs_y ∈ Joints2 ZS Y" obtains e where "⋀i. i < length (fst zs_y) ⟹ (fst zs_y) ! i = aform_val e (ZS ! i)" "snd (zs_y) = aform_val e Y" "⋀i. e i ∈ {-1..1}" using assms by atomize_elim (auto simp: Joints2_def Pi_iff valuate_ex) lemma nth_in_AffineI: assumes "xs ∈ Joints XS" assumes "i < length XS" shows "xs ! i ∈ Affine (XS ! i)" using assms by (force simp: Affine_def Joints_def valuate_def) lemma Cons_nth_in_Joints1: assumes "xs ∈ Joints XS" assumes "i < length XS" shows "((xs ! i) # xs) ∈ Joints ((XS ! i) # XS)" using assms by (force simp: Joints_def valuate_def) lemma Cons_nth_in_Joints2: assumes "xs ∈ Joints XS" assumes "i < length XS" assumes "j < length XS" shows "((xs ! i) #(xs ! j) # xs) ∈ Joints ((XS ! i)#(XS ! j) # XS)" using assms by (force simp: Joints_def valuate_def) lemma Joints_swap: "x#y#xs∈Joints (X#Y#XS) ⟷ y#x#xs ∈ Joints (Y#X#XS)" by (force simp: Joints_def valuate_def) lemma Joints_swap_Cons_append: "length xs = length XS ⟹ x#ys@xs∈Joints (X#YS@XS) ⟷ ys@x#xs ∈ Joints (YS@X#XS)" by (auto simp: Joints_def valuate_def) lemma Joints_ConsD: "x#xs∈Joints (X#XS) ⟹ xs ∈ Joints XS" by (force simp: Joints_def valuate_def) lemma Joints_appendD1: "ys@xs∈Joints (YS@XS) ⟹ length xs = length XS ⟹ xs ∈ Joints XS" by (force simp: Joints_def valuate_def) lemma Joints_appendD2: "ys@xs∈Joints (YS@XS) ⟹ length ys = length YS ⟹ ys ∈ Joints YS" by (force simp: Joints_def valuate_def) lemma Joints_imp_length_eq: "xs ∈ Joints XS ⟹ length xs = length XS" by (auto simp: Joints_def valuate_def) lemma Joints_rotate[simp]: "xs@[x] ∈ Joints (XS @[X]) ⟷ x#xs ∈ Joints (X#XS)" by (auto simp: Joints_def valuate_def) subsection ‹Domain› definition "pdevs_domain x = {i. pdevs_apply x i ≠ 0}" lemma finite_pdevs_domain[intro, simp]: "finite (pdevs_domain x)" unfolding pdevs_domain_def by transfer lemma in_pdevs_domain[simp]: "i ∈ pdevs_domain x ⟷ pdevs_apply x i ≠ 0" by (auto simp: pdevs_domain_def) subsection ‹Least Fresh Index› definition degree::"'a::real_vector pdevs ⇒ nat" where "degree x = (LEAST i. ∀j≥i. pdevs_apply x j = 0)" lemma degree[rule_format, intro, simp]: shows "∀j≥degree x. pdevs_apply x j = 0" unfolding degree_def proof (rule LeastI_ex) have "⋀j. j > Max (pdevs_domain x) ⟹ j ∉ (pdevs_domain x)" by (metis Max_less_iff all_not_in_conv less_irrefl_nat finite_pdevs_domain) then show "∃xa. ∀j≥xa. pdevs_apply x j = 0" by (auto intro!: exI[where x="Max (pdevs_domain x) + 1"]) qed lemma degree_le: assumes d: "∀j ≥ d. pdevs_apply x j = 0" shows "degree x ≤ d" unfolding degree_def by (rule Least_le) (rule d) lemma degree_gt: "pdevs_apply x j ≠ 0 ⟹ degree x > j" by auto lemma pdevs_val_pdevs_domain: "pdevs_val e X = (∑i∈pdevs_domain X. e i *⇩R pdevs_apply X i)" by (auto simp: pdevs_val_def intro!: suminf_finite) lemma pdevs_val_sum_le: "degree X ≤ d ⟹ pdevs_val e X = (∑i < d. e i *⇩R pdevs_apply X i)" by (force intro!: degree_gt sum.mono_neutral_cong_left simp: pdevs_val_pdevs_domain) lemmas pdevs_val_sum = pdevs_val_sum_le[OF order_refl] lemma pdevs_val_zero[simp]: "pdevs_val (λ_. 0) x = 0" by (auto simp: pdevs_val_sum) lemma degree_eqI: assumes "pdevs_apply x d ≠ 0" assumes "⋀j. j > d ⟹ pdevs_apply x j = 0" shows "degree x = Suc d" unfolding eq_iff by (auto intro!: degree_gt degree_le assms simp: Suc_le_eq) lemma finite_degree_nonzero[intro, simp]: "finite {i. pdevs_apply x i ≠ 0}" by transfer (auto simp: vimage_def Collect_neg_eq) lemma degree_eq_Suc_max: "degree x = (if (∀i. pdevs_apply x i = 0) then 0 else Suc (Max {i. pdevs_apply x i ≠ 0}))" proof - { assume "⋀i. pdevs_apply x i = 0" hence ?thesis by auto (metis degree_le le_0_eq) } moreover { fix i assume "pdevs_apply x i ≠ 0" hence ?thesis using Max_in[OF finite_degree_nonzero, of x] by (auto intro!: degree_eqI) (metis Max.coboundedI[OF finite_degree_nonzero] in_pdevs_domain le_eq_less_or_eq less_asym pdevs_domain_def) } ultimately show ?thesis by blast qed lemma pdevs_val_degree_cong: assumes "b = d" assumes "⋀i. i < degree b ⟹ a i = c i" shows "pdevs_val a b = pdevs_val c d" using assms by (auto simp: pdevs_val_sum) abbreviation degree_aform::"'a::real_vector aform ⇒ nat" where "degree_aform X ≡ degree (snd X)" lemma degree_cong: "(⋀i. (pdevs_apply x i = 0) = (pdevs_apply y i = 0)) ⟹ degree x = degree y" unfolding degree_def by auto lemma Least_True_nat[intro, simp]: "(LEAST i::nat. True) = 0" by (metis (lifting) One_nat_def less_one not_less_Least not_less_eq) lemma sorted_list_of_pdevs_domain_eq: "sorted_list_of_set (pdevs_domain X) = filter ((≠) 0 o pdevs_apply X) [0..<degree X]" by (auto simp: degree_gt intro!: sorted_distinct_set_unique sorted_filter[of "λx. x", simplified]) subsection ‹Total Deviation› definition tdev::"'a::ordered_euclidean_space pdevs ⇒ 'a" where "tdev x = (∑i<degree x. ¦pdevs_apply x i¦)" lemma abs_pdevs_val_le_tdev: "e ∈ UNIV → {-1 .. 1} ⟹ ¦pdevs_val e x¦ ≤ tdev x" by (force simp: pdevs_val_sum tdev_def abs_scaleR Pi_iff intro!: order_trans[OF sum_abs] sum_mono scaleR_left_le_one_le intro: abs_leI) subsection ‹Binary Pointwise Operations› definition binop_pdevs_raw::"('a::zero ⇒ 'b::zero ⇒ 'c::zero) ⇒ (nat ⇒ 'a) ⇒ (nat ⇒ 'b) ⇒ nat ⇒ 'c" where "binop_pdevs_raw f x y i = (if x i = 0 ∧ y i = 0 then 0 else f (x i) (y i))" lemma nonzeros_binop_pdevs_subset: "{i. binop_pdevs_raw f x y i ≠ 0} ⊆ {i. x i ≠ 0} ∪ {i. y i ≠ 0}" by (auto simp: binop_pdevs_raw_def) lift_definition binop_pdevs:: "('a ⇒ 'b ⇒ 'c) ⇒ 'a::zero pdevs ⇒ 'b::zero pdevs ⇒ 'c::zero pdevs" is binop_pdevs_raw using nonzeros_binop_pdevs_subset by (rule finite_subset) auto lemma pdevs_apply_binop_pdevs[simp]: "pdevs_apply (binop_pdevs f x y) i = (if pdevs_apply x i = 0 ∧ pdevs_apply y i = 0 then 0 else f (pdevs_apply x i) (pdevs_apply y i))" by transfer (auto simp: binop_pdevs_raw_def) subsection ‹Addition› definition add_pdevs::"'a::real_vector pdevs ⇒ 'a pdevs ⇒ 'a pdevs" where "add_pdevs = binop_pdevs (+)" lemma pdevs_apply_add_pdevs[simp]: "pdevs_apply (add_pdevs X Y) n = pdevs_apply X n + pdevs_apply Y n" by (auto simp: add_pdevs_def) lemma pdevs_val_add_pdevs[simp]: fixes x y::"'a::euclidean_space" shows "pdevs_val e (add_pdevs X Y) = pdevs_val e X + pdevs_val e Y" proof - let ?sum = "λm X. ∑i < m. e i *⇩R pdevs_apply X i" let ?m = "max (degree X) (degree Y)" have "pdevs_val e X + pdevs_val e Y = ?sum (degree X) X + ?sum (degree Y) Y" by (simp add: pdevs_val_sum) also have "?sum (degree X) X = ?sum ?m X" by (rule sum.mono_neutral_cong_left) auto also have "?sum (degree Y) Y = ?sum ?m Y" by (rule sum.mono_neutral_cong_left) auto also have "?sum ?m X + ?sum ?m Y = (∑i < ?m. e i *⇩R (pdevs_apply X i + pdevs_apply Y i))" by (simp add: scaleR_right_distrib sum.distrib) also have "… = (∑i. e i *⇩R (pdevs_apply X i + pdevs_apply Y i))" by (rule suminf_finite[symmetric]) auto also have "… = pdevs_val e (add_pdevs X Y)" by (simp add: pdevs_val_def) finally show "pdevs_val e (add_pdevs X Y) = pdevs_val e X + pdevs_val e Y" by simp qed subsection ‹Total Deviation› lemma tdev_eq_zero_iff: fixes X::"real pdevs" shows "tdev X = 0 ⟷ (∀e. pdevs_val e X = 0)" by (force simp add: pdevs_val_sum tdev_def sum_nonneg_eq_0_iff dest!: spec[where x="λi. if pdevs_apply X i ≥ 0 then 1 else -1"] split: if_split_asm) lemma tdev_nonneg[intro, simp]: "tdev X ≥ 0" by (auto simp: tdev_def) lemma tdev_nonpos_iff[simp]: "tdev X ≤ 0 ⟷ tdev X = 0" by (auto simp: order.antisym) subsection ‹Unary Operations› definition unop_pdevs_raw:: "('a::zero ⇒ 'b::zero) ⇒ (nat ⇒ 'a) ⇒ nat ⇒ 'b" where "unop_pdevs_raw f x i = (if x i = 0 then 0 else f (x i))" lemma nonzeros_unop_pdevs_subset: "{i. unop_pdevs_raw f x i ≠ 0} ⊆ {i. x i ≠ 0}" by (auto simp: unop_pdevs_raw_def) lift_definition unop_pdevs:: "('a ⇒ 'b) ⇒ 'a::zero pdevs ⇒ 'b::zero pdevs" is unop_pdevs_raw using nonzeros_unop_pdevs_subset by (rule finite_subset) auto lemma pdevs_apply_unop_pdevs[simp]: "pdevs_apply (unop_pdevs f x) i = (if pdevs_apply x i = 0 then 0 else f (pdevs_apply x i))" by transfer (auto simp: unop_pdevs_raw_def) lemma pdevs_domain_unop_linear: assumes "linear f" shows "pdevs_domain (unop_pdevs f x) ⊆ pdevs_domain x" proof - interpret f: linear f by fact show ?thesis by (auto simp: f.zero) qed lemma pdevs_val_unop_linear: assumes "linear f" shows "pdevs_val e (unop_pdevs f x) = f (pdevs_val e x)" proof - interpret f: linear f by fact have *: "⋀i. (if pdevs_apply x i = 0 then 0 else f (pdevs_apply x i)) = f (pdevs_apply x i)" by (auto simp: f.zero) have "pdevs_val e (unop_pdevs f x) = (∑i∈pdevs_domain (unop_pdevs f x). e i *⇩R f (pdevs_apply x i))" by (auto simp add: pdevs_val_pdevs_domain *) also have "… = (∑xa∈pdevs_domain x. e xa *⇩R f (pdevs_apply x xa))" by (auto intro!: sum.mono_neutral_cong_left) also have "… = f (pdevs_val e x)" by (auto simp add: pdevs_val_pdevs_domain f.sum f.scaleR) finally show ?thesis . qed subsection ‹Pointwise Scaling of Partial Deviations› definition scaleR_pdevs::"real ⇒ 'a::real_vector pdevs ⇒ 'a pdevs" where "scaleR_pdevs r x = unop_pdevs ((*⇩R) r) x" lemma pdevs_apply_scaleR_pdevs[simp]: "pdevs_apply (scaleR_pdevs x Y) n = x *⇩R pdevs_apply Y n" by (auto simp: scaleR_pdevs_def) lemma degree_scaleR_pdevs[simp]: "degree (scaleR_pdevs r x) = (if r = 0 then 0 else degree x)" unfolding degree_def by auto lemma pdevs_val_scaleR_pdevs[simp]: fixes x::real and Y::"'a::real_normed_vector pdevs" shows "pdevs_val e (scaleR_pdevs x Y) = x *⇩R pdevs_val e Y" by (auto simp: pdevs_val_sum scaleR_sum_right ac_simps) subsection ‹Partial Deviations Scale Pointwise› definition pdevs_scaleR::"real pdevs ⇒ 'a::real_vector ⇒ 'a pdevs" where "pdevs_scaleR r x = unop_pdevs (λr. r *⇩R x) r" lemma pdevs_apply_pdevs_scaleR[simp]: "pdevs_apply (pdevs_scaleR X y) n = pdevs_apply X n *⇩R y" by (auto simp: pdevs_scaleR_def) lemma degree_pdevs_scaleR[simp]: "degree (pdevs_scaleR r x) = (if x = 0 then 0 else degree r)" unfolding degree_def by auto lemma pdevs_val_pdevs_scaleR[simp]: fixes X::"real pdevs" and y::"'a::real_normed_vector" shows "pdevs_val e (pdevs_scaleR X y) = pdevs_val e X *⇩R y" by (auto simp: pdevs_val_sum scaleR_sum_left) subsection ‹Pointwise Unary Minus› definition uminus_pdevs::"'a::real_vector pdevs ⇒ 'a pdevs" where "uminus_pdevs = unop_pdevs uminus" lemma pdevs_apply_uminus_pdevs[simp]: "pdevs_apply (uminus_pdevs x) = - pdevs_apply x" by (auto simp: uminus_pdevs_def) lemma degree_uminus_pdevs[simp]: "degree (uminus_pdevs x) = degree x" by (rule degree_cong) simp lemma pdevs_val_uminus_pdevs[simp]: "pdevs_val e (uminus_pdevs x) = - pdevs_val e x" unfolding pdevs_val_sum by (auto simp: sum_negf) definition "uminus_aform X = (- fst X, uminus_pdevs (snd X))" lemma fst_uminus_aform[simp]: "fst (uminus_aform Y) = - fst Y" by (simp add: uminus_aform_def) lemma aform_val_uminus_aform[simp]: "aform_val e (uminus_aform X) = - aform_val e X" by (auto simp: uminus_aform_def aform_val_def) subsection ‹Constant› lift_definition zero_pdevs::"'a::zero pdevs" is "λ_. 0" by simp lemma pdevs_apply_zero_pdevs[simp]: "pdevs_apply zero_pdevs i = 0" by transfer simp lemma pdevs_val_zero_pdevs[simp]: "pdevs_val e zero_pdevs = 0" by (auto simp: pdevs_val_def) definition "num_aform f = (f, zero_pdevs)" subsection ‹Inner Product› definition pdevs_inner::"'a::euclidean_space pdevs ⇒ 'a ⇒ real pdevs" where "pdevs_inner x b = unop_pdevs (λx. x ∙ b) x" lemma pdevs_apply_pdevs_inner[simp]: "pdevs_apply (pdevs_inner p a) i = pdevs_apply p i ∙ a" by (simp add: pdevs_inner_def) lemma pdevs_val_pdevs_inner[simp]: "pdevs_val e (pdevs_inner p a) = pdevs_val e p ∙ a" by (auto simp add: inner_sum_left pdevs_val_pdevs_domain intro!: sum.mono_neutral_cong_left) definition inner_aform::"'a::euclidean_space aform ⇒ 'a ⇒ real aform" where "inner_aform X b = (fst X ∙ b, pdevs_inner (snd X) b)" subsection ‹Inner Product Pair› definition inner2::"'a::euclidean_space ⇒ 'a ⇒ 'a ⇒ real*real" where "inner2 x n l = (x ∙ n, x ∙ l)" definition pdevs_inner2::"'a::euclidean_space pdevs ⇒ 'a ⇒ 'a ⇒ (real*real) pdevs" where "pdevs_inner2 X n l = unop_pdevs (λx. inner2 x n l) X" lemma pdevs_apply_pdevs_inner2[simp]: "pdevs_apply (pdevs_inner2 p a b) i = (pdevs_apply p i ∙ a, pdevs_apply p i ∙ b)" by (simp add: pdevs_inner2_def inner2_def zero_prod_def) definition inner2_aform::"'a::euclidean_space aform ⇒ 'a ⇒ 'a ⇒ (real*real) aform" where "inner2_aform X a b = (inner2 (fst X) a b, pdevs_inner2 (snd X) a b)" lemma linear_inner2[intro, simp]: "linear (λx. inner2 x n i)" by unfold_locales (auto simp: inner2_def algebra_simps) lemma aform_val_inner2_aform[simp]: "aform_val e (inner2_aform Z n i) = inner2 (aform_val e Z) n i" proof - have "aform_val e (inner2_aform Z n i) = inner2 (fst Z) n i + inner2 (pdevs_val e (snd Z)) n i" by (auto simp: aform_val_def inner2_aform_def pdevs_inner2_def pdevs_val_unop_linear) also have "… = inner2 (aform_val e Z) n i" by (simp add: inner2_def algebra_simps aform_val_def) finally show ?thesis . qed subsection ‹Update› lemma pdevs_val_upd[simp]: "pdevs_val (e(n := e')) X = pdevs_val e X - e n * pdevs_apply X n + e' * pdevs_apply X n" unfolding pdevs_val_def by (subst suminf_finite[OF finite.insertI[OF finite_degree_nonzero], of n X], auto simp: pdevs_val_def sum.insert_remove)+ lemma nonzeros_fun_upd: "{i. (f(n := a)) i ≠ 0} ⊆ {i. f i ≠ 0} ∪ {n}" by (auto split: if_split_asm) lift_definition pdev_upd::"'a::real_vector pdevs ⇒ nat ⇒ 'a ⇒ 'a pdevs" is "λx n a. x(n:=a)" by (rule finite_subset[OF nonzeros_fun_upd]) simp lemma pdevs_apply_pdev_upd[simp]: "pdevs_apply (pdev_upd X n x) = (pdevs_apply X)(n:=x)" by transfer simp lemma pdevs_val_pdev_upd[simp]: "pdevs_val e (pdev_upd X n x) = pdevs_val e X + e n *⇩R x - e n *⇩R pdevs_apply X n" unfolding pdevs_val_def by (subst suminf_finite[OF finite.insertI[OF finite_degree_nonzero], of n X], auto simp: pdevs_val_def sum.insert_remove)+ lemma degree_pdev_upd: assumes "x = 0 ⟷ pdevs_apply X n = 0" shows "degree (pdev_upd X n x) = degree X" using assms by (auto intro!: degree_cong split: if_split_asm) lemma degree_pdev_upd_le: assumes "degree X ≤ n" shows "degree (pdev_upd X n x) ≤ Suc n" using assms by (auto intro!: degree_le) subsection ‹Inf/Sup› definition "Inf_aform X = fst X - tdev (snd X)" definition "Sup_aform X = fst X + tdev (snd X)" lemma Inf_aform: assumes "e ∈ UNIV → {-1 .. 1}" shows "Inf_aform X ≤ aform_val e X" using order_trans[OF abs_ge_minus_self abs_pdevs_val_le_tdev[OF assms]] by (auto simp: Inf_aform_def aform_val_def minus_le_iff) lemma Sup_aform: assumes "e ∈ UNIV → {-1 .. 1}" shows "aform_val e X ≤ Sup_aform X" using order_trans[OF abs_ge_self abs_pdevs_val_le_tdev[OF assms]] by (auto simp: Sup_aform_def aform_val_def) subsection ‹Minkowski Sum› definition msum_pdevs_raw::"nat⇒(nat ⇒ 'a::real_vector)⇒(nat ⇒ 'a)⇒(nat⇒'a)" where "msum_pdevs_raw n x y i = (if i < n then x i else y (i - n))" lemma nonzeros_msum_pdevs_raw: "{i. msum_pdevs_raw n f g i ≠ 0} = ({0..<n} ∩ {i. f i ≠ 0}) ∪ (+) n ` ({i. g i ≠ 0})" by (force simp: msum_pdevs_raw_def not_less split: if_split_asm) lift_definition msum_pdevs::"nat⇒'a::real_vector pdevs⇒'a pdevs⇒'a pdevs" is msum_pdevs_raw unfolding nonzeros_msum_pdevs_raw by simp lemma pdevs_apply_msum_pdevs: "pdevs_apply (msum_pdevs n f g) i = (if i < n then pdevs_apply f i else pdevs_apply g (i - n))" by transfer (auto simp: msum_pdevs_raw_def) lemma degree_least_nonzero: assumes "degree f ≠ 0" shows "pdevs_apply f (degree f - 1) ≠ 0" proof assume H: "pdevs_apply f (degree f - 1) = 0" { fix j assume "j≥degree f - 1" with H have "pdevs_apply f j = 0" by (cases "degree f - 1 = j") auto } from degree_le[rule_format, OF this] have "degree f ≤ degree f - 1" by blast with assms show False by simp qed lemma degree_leI: assumes "(⋀i. pdevs_apply y i = 0 ⟹ pdevs_apply x i = 0)" shows "degree x ≤ degree y" proof cases assume "degree x ≠ 0" from degree_least_nonzero[OF this] have "pdevs_apply y (degree x - 1) ≠ 0" by (auto simp: assms split: if_split_asm) from degree_gt[OF this] show ?thesis by simp qed simp lemma degree_msum_pdevs_ge1: shows "degree f ≤ n ⟹ degree f ≤ degree (msum_pdevs n f g)" by (rule degree_leI) (auto simp: pdevs_apply_msum_pdevs split: if_split_asm) lemma degree_msum_pdevs_ge2: assumes "degree f ≤ n" shows "degree g ≤ degree (msum_pdevs n f g) - n" proof cases assume "degree g ≠ 0" hence "pdevs_apply g (degree g - 1) ≠ 0" by (rule degree_least_nonzero) hence "pdevs_apply (msum_pdevs n f g) (n + degree g - 1) ≠ 0" using assms by (auto simp: pdevs_apply_msum_pdevs) from degree_gt[OF this] show ?thesis by simp qed simp lemma degree_msum_pdevs_le: shows "degree (msum_pdevs n f g) ≤ n + degree g" by (auto intro!: degree_le simp: pdevs_apply_msum_pdevs) lemma sum_msum_pdevs_cases: assumes "degree f ≤ n" assumes [simp]: "⋀i. e i 0 = 0" shows "(∑i <degree (msum_pdevs n f g). e i (if i < n then pdevs_apply f i else pdevs_apply g (i - n))) = (∑i <degree f. e i (pdevs_apply f i)) + (∑i <degree g. e (i + n) (pdevs_apply g i))" (is "?lhs = ?rhs") proof - have "?lhs = (∑i∈{..<degree (msum_pdevs n f g)} ∩ {i. i < n}. e i (pdevs_apply f i)) + (∑i∈{..<degree (msum_pdevs n f g)} ∩ - {i. i < n}. e i (pdevs_apply g (i - n)))" (is "_ = ?sum_f + ?sum_g") by (simp add: sum.If_cases if_distrib) also have "?sum_f = (∑i = 0..<degree f. e i (pdevs_apply f i))" using assms degree_msum_pdevs_ge1[of f n g] by (intro sum.mono_neutral_cong_right) auto also have "?sum_g = (∑i∈{0 + n..<degree (msum_pdevs n f g) - n + n}. e i (pdevs_apply g (i - n)))" by (rule sum.cong) auto also have "… = (∑i = 0..<degree (msum_pdevs n f g) - n. e (i + n) (pdevs_apply g (i + n - n)))" by (rule sum.shift_bounds_nat_ivl) also have "… = (∑i = 0..<degree g. e (i + n) (pdevs_apply g i))" using assms degree_msum_pdevs_ge2[of f n] by (intro sum.mono_neutral_cong_right) (auto intro!: sum.mono_neutral_cong_right) finally show ?thesis by (simp add: atLeast0LessThan) qed lemma tdev_msum_pdevs: "degree f ≤ n ⟹ tdev (msum_pdevs n f g) = tdev f + tdev g" by (auto simp: tdev_def pdevs_apply_msum_pdevs intro!: sum_msum_pdevs_cases) lemma pdevs_val_msum_pdevs: "degree f ≤ n ⟹ pdevs_val e (msum_pdevs n f g) = pdevs_val e f + pdevs_val (λi. e (i + n)) g" by (auto simp: pdevs_val_sum pdevs_apply_msum_pdevs intro!: sum_msum_pdevs_cases) definition msum_aform::"nat ⇒ 'a::real_vector aform ⇒ 'a aform ⇒ 'a aform" where "msum_aform n f g = (fst f + fst g, msum_pdevs n (snd f) (snd g))" lemma fst_msum_aform[simp]: "fst (msum_aform n f g) = fst f + fst g" by (simp add: msum_aform_def) lemma snd_msum_aform[simp]: "snd (msum_aform n f g) = msum_pdevs n (snd f) (snd g)" by (simp add: msum_aform_def) lemma finite_nonzero_summable: "finite {i. f i ≠ 0} ⟹ summable f" by (auto intro!: sums_summable sums_finite) lemma aform_val_msum_aform: assumes "degree_aform f ≤ n" shows "aform_val e (msum_aform n f g) = aform_val e f + aform_val (λi. e (i + n)) g" using assms by (auto simp: pdevs_val_msum_pdevs aform_val_def) lemma Inf_aform_msum_aform: "degree_aform X ≤ n ⟹ Inf_aform (msum_aform n X Y) = Inf_aform X + Inf_aform Y" by (simp add: Inf_aform_def tdev_msum_pdevs) lemma Sup_aform_msum_aform: "degree_aform X ≤ n ⟹ Sup_aform (msum_aform n X Y) = Sup_aform X + Sup_aform Y" by (simp add: Sup_aform_def tdev_msum_pdevs) definition "independent_from d Y = msum_aform d (0, zero_pdevs) Y" definition "independent_aform X Y = independent_from (degree_aform X) Y" lemma degree_zero_pdevs[simp]: "degree zero_pdevs = 0" by (metis degree_least_nonzero pdevs_apply_zero_pdevs) lemma independent_aform_Joints: assumes "x ∈ Affine X" assumes "y ∈ Affine Y" shows "[x, y] ∈ Joints [X, independent_aform X Y]" using assms unfolding Affine_def valuate_def Joints_def apply safe subgoal premises prems for e ea using prems by (intro image_eqI[where x="λi. if i < degree_aform X then e i else ea (i - degree_aform X)"]) (auto simp: aform_val_def pdevs_val_msum_pdevs Pi_iff independent_aform_def independent_from_def intro!: pdevs_val_degree_cong) done lemma msum_aform_Joints: assumes "d ≥ degree_aform X" assumes "⋀X. X ∈ set XS ⟹ d ≥ degree_aform X" assumes "(x#xs) ∈ Joints (X#XS)" assumes "y ∈ Affine Y" shows "((x + y)#x#xs) ∈ Joints (msum_aform d X Y#X#XS)" using assms unfolding Joints_def valuate_def Affine_def proof (safe, goal_cases) case (1 e ea a b zs) then show ?case by (intro image_eqI[where x = "λi. if i < d then e i else ea (i - d)"]) (force simp: aform_val_def pdevs_val_msum_pdevs intro!: intro!: pdevs_val_degree_cong)+ qed lemma Joints_msum_aform: assumes "d ≥ degree_aform X" assumes "⋀Y. Y ∈ set YS ⟹ d ≥ degree_aform Y" shows "Joints (msum_aform d X Y#YS) = {((x + y)#ys) |x y ys. y ∈ Affine Y ∧ x#ys ∈ Joints (X#YS)}" unfolding Affine_def valuate_def Joints_def proof (safe, goal_cases) case (1 x e) thus ?case using assms by (intro exI[where x = "aform_val e X"] exI[where x = "aform_val ((λi. e (i + d))) Y"]) (auto simp add: aform_val_def pdevs_val_msum_pdevs) next case (2 x xa y ys e ea) thus ?case using assms by (intro image_eqI[where x="λi. if i < d then ea i else e (i - d)"]) (force simp: aform_val_def pdevs_val_msum_pdevs Pi_iff intro!: pdevs_val_degree_cong)+ qed lemma Joints_singleton_image: "Joints [x] = (λx. [x]) ` Affine x" by (auto simp: Joints_def Affine_def valuate_def) lemma Collect_extract_image: "{g (f x y) |x y. P x y} = g ` {f x y |x y. P x y}" by auto lemma inj_Cons: "inj (λx. x#xs)" by (auto intro!: injI) lemma Joints_Nil[simp]: "Joints [] = {[]}" by (force simp: Joints_def valuate_def) lemma msum_pdevs_zero_ident[simp]: "msum_pdevs 0 zero_pdevs x = x" by transfer (auto simp: msum_pdevs_raw_def) lemma msum_aform_zero_ident[simp]: "msum_aform 0 (0, zero_pdevs) x = x" by (simp add: msum_aform_def) lemma mem_Joints_singleton: "(x ∈ Joints [X]) = (∃y. x = [y] ∧ y ∈ Affine X)" by (auto simp: Affine_def valuate_def Joints_def) lemma singleton_mem_Joints[simp]: "[x] ∈ Joints [X] ⟷ x ∈ Affine X" by (auto simp: mem_Joints_singleton) lemma msum_aform_Joints_without_first: assumes "d ≥ degree_aform X" assumes "⋀X. X ∈ set XS ⟹ d ≥ degree_aform X" assumes "(x#xs) ∈ Joints (X#XS)" assumes "y ∈ Affine Y" assumes "z = x + y" shows "z#xs ∈ Joints (msum_aform d X Y#XS)" unfolding ‹z = x + y› using msum_aform_Joints[OF assms(1-4)] by (force simp: Joints_def valuate_def) lemma Affine_msum_aform: assumes "d ≥ degree_aform X" shows "Affine (msum_aform d X Y) = {x + y |x y. x ∈ Affine X ∧ y ∈ Affine Y}" using Joints_msum_aform[OF assms, of Nil Y, simplified, unfolded mem_Joints_singleton] by (auto simp add: Joints_singleton_image Collect_extract_image[where g="λx. [x]"] inj_image_eq_iff[OF inj_Cons] ) lemma Affine_zero_pdevs[simp]: "Affine (0, zero_pdevs) = {0}" by (force simp: Affine_def valuate_def aform_val_def) lemma Affine_independent_aform: "Affine (independent_aform X Y) = Affine Y" by (auto simp: independent_aform_def independent_from_def Affine_msum_aform) lemma abs_diff_eq1: fixes l u::"'a::ordered_euclidean_space" shows "l ≤ u ⟹ ¦u - l¦ = u - l" by (metis abs_of_nonneg diff_add_cancel le_add_same_cancel2) lemma compact_sum: fixes f :: "'a ⇒ 'b::topological_space ⇒ 'c::real_normed_vector" assumes "finite I" assumes "⋀i. i ∈ I ⟹ compact (S i)" assumes "⋀i. i ∈ I ⟹ continuous_on (S i) (f i)" assumes "I ⊆ J" shows "compact {∑i∈I. f i (x i) | x. x ∈ Pi J S}" using assms proof (induct I) case empty thus ?case proof (cases "∃x. x ∈ Pi J S") case False hence *: "{∑i∈{}. f i (x i) |x. x ∈ Pi J S} = {}" by (auto simp: Pi_iff) show ?thesis unfolding * by simp qed auto next case (insert a I) hence "{∑i∈insert a I. f i (xa i) |xa. xa ∈ Pi J S} = {x + y |x y. x ∈ f a ` S a ∧ y ∈ {∑i∈I. f i (x i) |x. x ∈ Pi J S}}" proof safe fix s x assume "s ∈ S a" "x ∈ Pi J S" thus "∃xa. f a s + (∑i∈I. f i (x i)) = (∑i∈insert a I. f i (xa i)) ∧ xa ∈ Pi J S" using insert by (auto intro!: exI[where x="x(a:=s)"] sum.cong) qed force also have "compact …" using insert by (intro compact_sums) (auto intro!: compact_continuous_image) finally show ?case . qed lemma compact_Affine: fixes X::"'a::ordered_euclidean_space aform" shows "compact (Affine X)" proof - have "Affine X = {x + y|x y. x ∈ {fst X} ∧ y ∈ {(∑i ∈ {0..<degree_aform X}. e i *⇩R pdevs_apply (snd X) i) | e. e ∈ UNIV → {-1 .. 1}}}" by (auto simp: Affine_def valuate_def aform_val_def pdevs_val_sum atLeast0LessThan) also have "compact …" by (rule compact_sums) (auto intro!: compact_sum continuous_intros) finally show ?thesis . qed lemma Joints2_JointsI: "(xs, x) ∈ Joints2 XS X ⟹ x#xs ∈ Joints (X#XS)" by (auto simp: Joints_def Joints2_def valuate_def) subsection ‹Splitting› definition "split_aform X i = (let xi = pdevs_apply (snd X) i /⇩R 2 in ((fst X - xi, pdev_upd (snd X) i xi), (fst X + xi, pdev_upd (snd X) i xi)))" lemma split_aformE: assumes "e ∈ UNIV → {-1 .. 1}" assumes "x = aform_val e X" obtains err where "x = aform_val (e(i:=err)) (fst (split_aform X i))" "err ∈ {-1 .. 1}" | err where "x = aform_val (e(i:=err)) (snd (split_aform X i))" "err ∈ {-1 .. 1}" proof (atomize_elim) let ?thesis = "(∃err. x = aform_val (e(i := err)) (fst (split_aform X i)) ∧ err ∈ {- 1..1}) ∨ (∃err. x = aform_val (e(i := err)) (snd (split_aform X i)) ∧ err ∈ {- 1..1})" { assume "pdevs_apply (snd X) i = 0" hence "X = fst (split_aform X i)" by (auto simp: split_aform_def intro!: prod_eqI pdevs_eqI) with assms have ?thesis by (auto intro!: exI[where x="e i"]) } moreover { assume "pdevs_apply (snd X) i ≠ 0" hence [simp]: "degree_aform X > i" by (rule degree_gt) note assms(2) also have "aform_val e X = fst X + (∑i<degree_aform X. e i *⇩R pdevs_apply (snd X) i)" by (simp add: aform_val_def pdevs_val_sum) also have rewr: "{..<degree_aform X} = {0..<degree_aform X} - {i} ∪ {i}" by auto have "(∑i<degree_aform X. e i *⇩R pdevs_apply (snd X) i) = (∑i ∈ {0..<degree_aform X} - {i}. e i *⇩R pdevs_apply (snd X) i) + e i *⇩R pdevs_apply (snd X) i" by (subst rewr, subst sum.union_disjoint) auto finally have "x = fst X + …" . hence "x = aform_val (e(i:=2 * e i - 1)) (snd (split_aform X i))" "x = aform_val (e(i:=2 * e i + 1)) (fst (split_aform X i))" by (auto simp: aform_val_def split_aform_def Let_def pdevs_val_sum atLeast0LessThan Diff_eq degree_pdev_upd if_distrib sum.If_cases field_simps scaleR_left_distrib[symmetric]) moreover have "2 * e i - 1 ∈ {-1 .. 1} ∨ 2 * e i + 1 ∈ {-1 .. 1}" using assms by (auto simp: not_le Pi_iff dest!: spec[where x=i]) ultimately have ?thesis by blast } ultimately show ?thesis by blast qed lemma pdevs_val_add: "pdevs_val (λi. e i + f i) xs = pdevs_val e xs + pdevs_val f xs" by (auto simp: pdevs_val_pdevs_domain algebra_simps sum.distrib) lemma pdevs_val_minus: "pdevs_val (λi. e i - f i) xs = pdevs_val e xs - pdevs_val f xs" by (auto simp: pdevs_val_pdevs_domain algebra_simps sum_subtractf) lemma pdevs_val_cmul: "pdevs_val (λi. u * e i) xs = u *⇩R pdevs_val e xs" by (auto simp: pdevs_val_pdevs_domain scaleR_sum_right) lemma atLeastAtMost_absI: "- a ≤ a ⟹ ¦x::real¦ ≤ ¦a¦ ⟹ x ∈ atLeastAtMost (- a) a" by auto lemma divide_atLeastAtMost_1_absI: "¦x::real¦ ≤ ¦a¦ ⟹ x/a ∈ {-1 .. 1}" by (intro atLeastAtMost_absI) (auto simp: divide_le_eq_1) lemma convex_scaleR_aux: "u + v = 1 ⟹ u *⇩R x + v *⇩R x = (x::'a::real_vector)" by (metis scaleR_add_left scaleR_one) lemma convex_mult_aux: "u + v = 1 ⟹ u * x + v * x = (x::real)" using convex_scaleR_aux[of u v x] by simp lemma convex_Affine: "convex (Affine X)" proof (rule convexI) fix x y::'a and u v::real assume "x ∈ Affine X" "y ∈ Affine X" and convex: "0 ≤ u" "0 ≤ v" "u + v = 1" then obtain e f where x: "x = aform_val e X" "e ∈ UNIV → {-1 .. 1}" and y: "y = aform_val f X" "f ∈ UNIV → {-1 .. 1}" by (auto simp: Affine_def valuate_def) let ?conv = "λi. u * e i + v * f i" { fix i have "¦?conv i¦ ≤ u * ¦e i¦ + v * ¦f i¦" using convex by (intro order_trans[OF abs_triangle_ineq]) (simp add: abs_mult) also have "… ≤ 1" using convex x y by (intro convex_bound_le) (auto simp: Pi_iff abs_real_def) finally have "?conv i ≤ 1" "-1 ≤ ?conv i" by (auto simp: abs_real_def split: if_split_asm) } thus "u *⇩R x + v *⇩R y ∈ Affine X" using convex x y by (auto simp: Affine_def valuate_def aform_val_def pdevs_val_add pdevs_val_cmul algebra_simps convex_scaleR_aux intro!: image_eqI[where x="?conv"]) qed lemma segment_in_aform_val: assumes "e ∈ UNIV → {-1 .. 1}" assumes "f ∈ UNIV → {-1 .. 1}" shows "closed_segment (aform_val e X) (aform_val f X) ⊆ Affine X" proof - have "aform_val e X ∈ Affine X" "aform_val f X ∈ Affine X" using assms by (auto simp: Affine_def valuate_def) with convex_Affine[of X, simplified convex_contains_segment] show ?thesis by simp qed subsection ‹From List of Generators› lift_definition pdevs_of_list::"'a::zero list ⇒ 'a pdevs" is "λxs i. if i < length xs then xs ! i else 0" by auto lemma pdevs_apply_pdevs_of_list: "pdevs_apply (pdevs_of_list xs) i = (if i < length xs then xs ! i else 0)" by transfer simp lemma pdevs_apply_pdevs_of_list_Nil[simp]: "pdevs_apply (pdevs_of_list []) i = 0" by transfer auto lemma pdevs_apply_pdevs_of_list_Cons: "pdevs_apply (pdevs_of_list (x # xs)) i = (if i = 0 then x else pdevs_apply (pdevs_of_list xs) (i - 1))" by transfer auto lemma pdevs_domain_pdevs_of_list_Cons[simp]: "pdevs_domain (pdevs_of_list (x # xs)) = (if x = 0 then {} else {0}) ∪ (+) 1 ` pdevs_domain (pdevs_of_list xs)" by (force simp: pdevs_apply_pdevs_of_list_Cons split: if_split_asm) lemma pdevs_val_pdevs_of_list_eq[simp]: "pdevs_val e (pdevs_of_list (x # xs)) = e 0 *⇩R x + pdevs_val (e o (+) 1) (pdevs_of_list xs)" proof - have "pdevs_val e (pdevs_of_list (x # xs)) = (∑i∈pdevs_domain (pdevs_of_list (x # xs)) ∩ {0}. e i *⇩R x) + (∑i∈pdevs_domain (pdevs_of_list (x # xs)) ∩ - {0}. e i *⇩R pdevs_apply (pdevs_of_list xs) (i - Suc 0))" (is "_ = ?l + ?r") by (simp add: pdevs_val_pdevs_domain if_distrib sum.If_cases pdevs_apply_pdevs_of_list_Cons) also have "?r = (∑i∈pdevs_domain (pdevs_of_list xs). e (Suc i) *⇩R pdevs_apply (pdevs_of_list xs) i)" by (rule sum.reindex_cong[of "λi. i + 1"]) auto also have "… = pdevs_val (e o (+) 1) (pdevs_of_list xs)" by (simp add: pdevs_val_pdevs_domain ) also have "?l = (∑i∈{0}. e i *⇩R x)" by (rule sum.mono_neutral_cong_left) auto also have "… = e 0 *⇩R x" by simp finally show ?thesis . qed lemma less_degree_pdevs_of_list_imp_less_length: assumes "i < degree (pdevs_of_list xs)" shows "i < length xs" proof - from assms have "pdevs_apply (pdevs_of_list xs) (degree (pdevs_of_list xs) - 1) ≠ 0" by (metis degree_least_nonzero less_nat_zero_code) hence "degree (pdevs_of_list xs) - 1 < length xs" by (simp add: pdevs_apply_pdevs_of_list split: if_split_asm) with assms show ?thesis by simp qed lemma tdev_pdevs_of_list[simp]: "tdev (pdevs_of_list xs) = sum_list (map abs xs)" by (auto simp: tdev_def pdevs_apply_pdevs_of_list sum_list_sum_nth less_degree_pdevs_of_list_imp_less_length intro!: sum.mono_neutral_cong_left degree_gt) lemma pdevs_of_list_Nil[simp]: "pdevs_of_list [] = zero_pdevs" by (auto intro!: pdevs_eqI) lemma pdevs_val_inj_sumI: fixes K::"'a set" and g::"'a ⇒ nat" assumes "finite K" assumes "inj_on g K" assumes "pdevs_domain x ⊆ g ` K" assumes "⋀i. i ∈ K ⟹ g i ∉ pdevs_domain x ⟹ f i = 0" assumes "⋀i. i ∈ K ⟹ g i ∈ pdevs_domain x ⟹ f i = e (g i) *⇩R pdevs_apply x (g i)" shows "pdevs_val e x = (∑i∈K. f i)" proof - have [simp]: "inj_on (the_inv_into K g) (pdevs_domain x)" using assms by (auto simp: intro!: subset_inj_on[OF inj_on_the_inv_into]) { fix y assume y: "y ∈ pdevs_domain x" have g_inv: "g (the_inv_into K g y) = y" by (meson assms(2) assms(3) y f_the_inv_into_f subset_eq) have inv_in: "the_inv_into K g y ∈ K" by (meson assms(2) assms(3) y subset_iff in_pdevs_domain the_inv_into_into) have inv3: "the_inv_into (pdevs_domain x) (the_inv_into K g) (the_inv_into K g y) = g (the_inv_into K g y)" using assms y by (subst the_inv_into_f_f) (auto simp: f_the_inv_into_f[OF assms(2)]) note g_inv inv_in inv3 } note this[simp] have "pdevs_val e x = (∑i∈pdevs_domain x. e i *⇩R pdevs_apply x i)" by (simp add: pdevs_val_pdevs_domain) also have "… = (∑i ∈ the_inv_into K g ` pdevs_domain x. e (g i) *⇩R pdevs_apply x (g i))" by (rule sum.reindex_cong[OF inj_on_the_inv_into]) auto also have "… = (∑i∈K. f i)" using assms by (intro sum.mono_neutral_cong_left) (auto simp: the_inv_into_image_eq) finally show ?thesis . qed lemma pdevs_domain_pdevs_of_list_le: "pdevs_domain (pdevs_of_list xs) ⊆ {0..<length xs}" by (auto simp: pdevs_apply_pdevs_of_list split: if_split_asm) lemma pdevs_val_zip: "pdevs_val e (pdevs_of_list xs) = (∑(i,x)←zip [0..<length xs] xs. e i *⇩R x)" by (auto simp: sum_list_distinct_conv_sum_set in_set_zip image_fst_zip pdevs_apply_pdevs_of_list distinct_zipI1 intro!: pdevs_val_inj_sumI[of _ fst] split: if_split_asm) lemma scaleR_sum_list: fixes xs::"'a::real_vector list" shows "a *⇩R sum_list xs = sum_list (map (scaleR a) xs)" by (induct xs) (auto simp: algebra_simps) lemma pdevs_val_const_pdevs_of_list: "pdevs_val (λ_. c) (pdevs_of_list xs) = c *⇩R sum_list xs" unfolding pdevs_val_zip split_beta' scaleR_sum_list by (rule arg_cong) (auto intro!: nth_equalityI) lemma pdevs_val_partition: assumes "e ∈ UNIV → I" obtains f g where "pdevs_val e (pdevs_of_list xs) = pdevs_val f (pdevs_of_list (filter p xs)) + pdevs_val g (pdevs_of_list (filter (Not o p) xs))" "f ∈ UNIV → I" "g ∈ UNIV → I" proof - obtain i where i: "i ∈ I" by (metis assms funcset_mem iso_tuple_UNIV_I) let ?zip = "zip [0..<length xs] xs" define part where "part = partition (p ∘ snd) ?zip" let ?f = "(λn. if n < degree (pdevs_of_list (filter p xs)) then e (map fst (fst part) ! n) else i)" let ?g = "(λn. if n < degree (pdevs_of_list (filter (Not ∘ p) xs)) then e (map fst (snd part) ! n) else i)" show ?thesis proof have "pdevs_val e (pdevs_of_list xs) = (∑(i,x)←?zip. e i *⇩R x)" by (rule pdevs_val_zip) also have "… = (∑(i, x)∈set ?zip. e i *⇩R x)" by (simp add: sum_list_distinct_conv_sum_set distinct_zipI1) also have [simp]: "set (fst part) ∩ set (snd part) = {}" by (auto simp: part_def) from partition_set[of "p o snd" ?zip "fst part" "snd part"] have "set ?zip = set (fst part) ∪ set (snd part)" by (auto simp: part_def) also have "(∑a∈set (fst part) ∪ set (snd part). case a of (i, x) ⇒ e i *⇩R x) = (∑(i, x)∈set (fst part). e i *⇩R x) + (∑(i, x)∈set (snd part). e i *⇩R x)" by (auto simp: split_beta sum_Un) also have "(∑(i, x)∈set (fst part). e i *⇩R x) = (∑(i, x)←(fst part). e i *⇩R x)" by (simp add: sum_list_distinct_conv_sum_set distinct_zipI1 part_def) also have "… = (∑i<length (fst part). case (fst part ! i) of (i, x) ⇒ e i *⇩R x)" by (subst sum_list_sum_nth) (simp add: split_beta' atLeast0LessThan) also have "… = pdevs_val (λn. e (map fst (fst part) ! n)) (pdevs_of_list (map snd (fst part)))" by (force simp: pdevs_val_zip sum_list_distinct_conv_sum_set distinct_zipI1 split_beta' in_set_zip intro!: sum.reindex_cong[where l=fst] image_eqI[where x = "(x, map snd (fst part) ! x)" for x]) also have "(∑(i, x)∈set (snd part). e i *⇩R x) = (∑(i, x)←(snd part). e i *⇩R x)" by (simp add: sum_list_distinct_conv_sum_set distinct_zipI1 part_def) also have "… = (∑i<length (snd part). case (snd part ! i) of (i, x) ⇒ e i *⇩R x)" by (subst sum_list_sum_nth) (simp add: split_beta' atLeast0LessThan) also have "… = pdevs_val (λn. e (map fst (snd part) ! n)) (pdevs_of_list (map snd (snd part)))" by (force simp: pdevs_val_zip sum_list_distinct_conv_sum_set distinct_zipI1 split_beta' in_set_zip intro!: sum.reindex_cong[where l=fst] image_eqI[where x = "(x, map snd (snd part) ! x)" for x]) also have "pdevs_val (λn. e (map fst (fst part) ! n)) (pdevs_of_list (map snd (fst part))) = pdevs_val (λn. if n < degree (pdevs_of_list (map snd (fst part))) then e (map fst (fst part) ! n) else i) (pdevs_of_list (map snd (fst part)))" by (rule pdevs_val_degree_cong) simp_all also have "pdevs_val (λn. e (map fst (snd part) ! n)) (pdevs_of_list (map snd (snd part))) = pdevs_val (λn. if n < degree (pdevs_of_list (map snd (snd part))) then e (map fst (snd part) ! n) else i) (pdevs_of_list (map snd (snd part)))" by (rule pdevs_val_degree_cong) simp_all also have "map snd (snd part) = filter (Not o p) xs" by (simp add: part_def filter_map[symmetric] o_assoc) also have "map snd (fst part) = filter p xs" by (simp add: part_def filter_map[symmetric]) finally show "pdevs_val e (pdevs_of_list xs) = pdevs_val ?f (pdevs_of_list (filter p xs)) + pdevs_val ?g (pdevs_of_list (filter (Not ∘ p) xs))" . show "?f ∈ UNIV → I" "?g ∈ UNIV → I" using assms ‹i∈I› by (auto simp: Pi_iff) qed qed lemma pdevs_apply_pdevs_of_list_append: "pdevs_apply (pdevs_of_list (xs @ zs)) i = (if i < length xs then pdevs_apply (pdevs_of_list xs) i else pdevs_apply (pdevs_of_list zs) (i - length xs))" by (auto simp: pdevs_apply_pdevs_of_list nth_append) lemma degree_pdevs_of_list_le_length[intro, simp]: "degree (pdevs_of_list xs) ≤ length xs" by (metis less_irrefl_nat le_less_linear less_degree_pdevs_of_list_imp_less_length) lemma degree_pdevs_of_list_append: "degree (pdevs_of_list (xs @ ys)) ≤ length xs + degree (pdevs_of_list ys)" by (rule degree_le) (auto simp: pdevs_apply_pdevs_of_list_append) lemma pdevs_val_pdevs_of_list_append: assumes "f ∈ UNIV → I" assumes "g ∈ UNIV → I" obtains e where "pdevs_val f (pdevs_of_list xs) + pdevs_val g (pdevs_of_list ys) = pdevs_val e (pdevs_of_list (xs @ ys))" "e ∈ UNIV → I" proof let ?e = "(λi. if i < length xs then f i else g (i - length xs))" have f: "pdevs_val f (pdevs_of_list xs) = (∑i∈{..<length xs}. ?e i *⇩R pdevs_apply (pdevs_of_list (xs @ ys)) i)" by (auto simp: pdevs_val_sum degree_gt pdevs_apply_pdevs_of_list_append intro: sum.mono_neutral_cong_left) have g: "pdevs_val g (pdevs_of_list ys) = (∑i=length xs ..<length xs + degree (pdevs_of_list ys). ?e i *⇩R pdevs_apply (pdevs_of_list (xs @ ys)) i)" (is "_ = ?sg") by (auto simp: pdevs_val_sum pdevs_apply_pdevs_of_list_append intro!: inj_onI image_eqI[where x="length xs + x" for x] sum.reindex_cong[where l="λi. i - length xs"]) show "pdevs_val f (pdevs_of_list xs) + pdevs_val g (pdevs_of_list ys) = pdevs_val ?e (pdevs_of_list (xs @ ys))" unfolding f g by (subst sum.union_disjoint[symmetric]) (force simp: pdevs_val_sum ivl_disj_un degree_pdevs_of_list_append intro!: sum.mono_neutral_cong_right split: if_split_asm)+ show "?e ∈ UNIV → I" using assms by (auto simp: Pi_iff) qed lemma sum_general_mono: fixes f::"'a⇒('b::ordered_ab_group_add)" assumes [simp,intro]: "finite s" "finite t" assumes f: "⋀x. x ∈ s - t ⟹ f x ≤ 0" assumes g: "⋀x. x ∈ t - s ⟹ g x ≥ 0" assumes fg: "⋀x. x ∈ s ∩ t ⟹ f x ≤ g x" shows "(∑x ∈ s. f x) ≤ (∑x ∈ t. g x)" proof - have "s = (s - t) ∪ (s ∩ t)" and [intro, simp]: "(s - t) ∩ (s ∩ t) = {}" by auto hence "(∑x ∈ s. f x) = (∑x ∈ s - t ∪ s ∩ t. f x)" using assms by simp also have "… = (∑x ∈ s - t. f x) + (∑x ∈ s ∩ t. f x)" by (simp add: sum_Un) also have "(∑x ∈ s - t. f x) ≤ 0" by (auto intro!: sum_nonpos f) also have "0 ≤ (∑x ∈ t - s. g x)" by (auto intro!: sum_nonneg g) also have "(∑x ∈ s ∩ t. f x) ≤ (∑x ∈ s ∩ t. g x)" by (auto intro!: sum_mono fg) also have [intro, simp]: "(t - s) ∩ (s ∩ t) = {}" by auto hence "sum g (t - s) + sum g (s ∩ t) = sum g ((t - s) ∪ (s ∩ t))" by (simp add: sum_Un) also have "… = sum g t" by (auto intro!: sum.cong) finally show ?thesis by simp qed lemma pdevs_val_perm_ex: assumes "xs <~~> ys" assumes mem: "e ∈ UNIV → I" shows "∃e'. e' ∈ UNIV → I ∧ pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list ys)" using assms proof (induct arbitrary: e) case Nil thus ?case by auto next case (Cons xs ys z) hence "(e ∘ (+) (Suc 0)) ∈ UNIV → I" by auto from Cons(2)[OF this] obtain e' where "e' ∈ UNIV → I" "pdevs_val (e ∘ (+) (Suc 0)) (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list ys)" by metis thus ?case using Cons by (auto intro!: exI[where x="λx. if x = 0 then e 0 else e' (x - 1)"] simp: o_def Pi_iff) next case (trans xs ys zs) thus ?case by metis next case (swap y x l) thus ?case by (auto intro!: exI[where x="λi. if i = 0 then e 1 else if i = 1 then e 0 else e i"] simp: o_def Pi_iff) qed lemma pdevs_val_perm: assumes "xs <~~> ys" assumes mem: "e ∈ UNIV → I" obtains e' where "e' ∈ UNIV → I" "pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list ys)" using assms by (metis pdevs_val_perm_ex) lemma set_distinct_permI: "set xs = set ys ⟹ distinct xs ⟹ distinct ys ⟹ xs <~~> ys" by (metis eq_set_perm_remdups remdups_id_iff_distinct) lemmas pdevs_val_permute = pdevs_val_perm[OF set_distinct_permI] lemma partition_permI: "filter p xs @ filter (Not o p) xs <~~> xs" proof (induct xs) case (Cons x xs) have swap_app_Cons: "filter p xs @ x # [a←xs . ¬ p a] <~~> x # filter p xs @ [a←xs . ¬ p a]" by (metis perm_sym perm_append_Cons) also have "… <~~> x#xs" using Cons by auto finally (trans) show ?case using Cons by simp qed simp lemma pdevs_val_eqI: assumes "⋀i. i ∈ pdevs_domain y ⟹ i ∈ pdevs_domain x ⟹ e i *⇩R pdevs_apply x i = f i *⇩R pdevs_apply y i" assumes "⋀i. i ∈ pdevs_domain y ⟹ i ∉ pdevs_domain x ⟹ f i *⇩R pdevs_apply y i = 0" assumes "⋀i. i ∈ pdevs_domain x ⟹ i ∉ pdevs_domain y ⟹ e i *⇩R pdevs_apply x i = 0" shows "pdevs_val e x = pdevs_val f y" using assms by (force simp: pdevs_val_pdevs_domain intro!: sum.reindex_bij_witness_not_neutral[where i=id and j = id and S'="pdevs_domain x - pdevs_domain y" and T'="pdevs_domain y - pdevs_domain x"]) definition filter_pdevs_raw::"(nat ⇒ 'a ⇒ bool) ⇒ (nat ⇒ 'a::real_vector) ⇒ (nat ⇒ 'a)" where "filter_pdevs_raw I X = (λi. if I i (X i) then X i else 0)" lemma filter_pdevs_raw_nonzeros: "{i. filter_pdevs_raw s f i ≠ 0} = {i. f i ≠ 0} ∩ {x. s x (f x)}" by (auto simp: filter_pdevs_raw_def) lift_definition filter_pdevs::"(nat ⇒ 'a ⇒ bool) ⇒ 'a::real_vector pdevs ⇒ 'a pdevs" is filter_pdevs_raw by (simp add: filter_pdevs_raw_nonzeros) lemma pdevs_apply_filter_pdevs[simp]: "pdevs_apply (filter_pdevs I x) i = (if I i (pdevs_apply x i) then pdevs_apply x i else 0)" by transfer (auto simp: filter_pdevs_raw_def) lemma degree_filter_pdevs_le: "degree (filter_pdevs I x) ≤ degree x" by (rule degree_leI) (simp split: if_split_asm) lemma pdevs_val_filter_pdevs: "pdevs_val e (filter_pdevs I x) = (∑i ∈ {..<degree x} ∩ {i. I i (pdevs_apply x i)}. e i *⇩R pdevs_apply x i)" by (auto simp: pdevs_val_sum if_distrib sum.inter_restrict degree_filter_pdevs_le degree_gt intro!: sum.mono_neutral_cong_left split: if_split_asm) lemma pdevs_val_filter_pdevs_dom: "pdevs_val e (filter_pdevs I x) = (∑i ∈ pdevs_domain x ∩ {i. I i (pdevs_apply x i)}. e i *⇩R pdevs_apply x i)" by (auto simp: pdevs_val_pdevs_domain if_distrib sum.inter_restrict degree_filter_pdevs_le degree_gt intro!: sum.mono_neutral_cong_left split: if_split_asm) lemma pdevs_val_filter_pdevs_eval: "pdevs_val e (filter_pdevs p x) = pdevs_val (λi. if p i (pdevs_apply x i) then e i else 0) x" by (auto split: if_split_asm intro!: pdevs_val_eqI) definition "pdevs_applys X i = map (λx. pdevs_apply x i) X" definition "pdevs_vals e X = map (pdevs_val e) X" definition "aform_vals e X = map (aform_val e) X" definition "filter_pdevs_list I X = map (filter_pdevs (λi _. I i (pdevs_applys X i))) X" lemma pdevs_applys_filter_pdevs_list[simp]: "pdevs_applys (filter_pdevs_list I X) i = (if I i (pdevs_applys X i) then pdevs_applys X i else map (λ_. 0) X)" by (auto simp: filter_pdevs_list_def o_def pdevs_applys_def) definition "degrees X = Max (insert 0 (degree ` set X))" abbreviation "degree_aforms X ≡ degrees (map snd X)" lemma degrees_leI: assumes "⋀x. x ∈ set X ⟹ degree x ≤ K" shows "degrees X ≤ K" using assms by (auto simp: degrees_def intro!: Max.boundedI) lemma degrees_leD: assumes "degrees X ≤ K" shows "⋀x. x ∈ set X ⟹ degree x ≤ K" using assms by (auto simp: degrees_def intro!: Max.boundedI) lemma degree_filter_pdevs_list_le: "degrees (filter_pdevs_list I x) ≤ degrees x" by (rule degrees_leI) (auto simp: filter_pdevs_list_def intro!: degree_le dest!: degrees_leD) definition "dense_list_of_pdevs x = map (λi. pdevs_apply x i) [0..<degree x]" subsubsection ‹(reverse) ordered coefficients as list› definition "list_of_pdevs x = map (λi. (i, pdevs_apply x i)) (rev (sorted_list_of_set (pdevs_domain x)))" lemma list_of_pdevs_zero_pdevs[simp]: "list_of_pdevs zero_pdevs = []" by (auto simp: list_of_pdevs_def) lemma sum_list_list_of_pdevs: "sum_list (map snd (list_of_pdevs x)) = sum_list (dense_list_of_pdevs x)" by (auto intro!: sum.mono_neutral_cong_left simp add: degree_gt sum_list_distinct_conv_sum_set dense_list_of_pdevs_def list_of_pdevs_def) lemma sum_list_filter_dense_list_of_pdevs[symmetric]: "sum_list (map snd (filter (p o snd) (list_of_pdevs x))) = sum_list (filter p (dense_list_of_pdevs x))" by (auto intro!: sum.mono_neutral_cong_left simp add: degree_gt sum_list_distinct_conv_sum_set dense_list_of_pdevs_def list_of_pdevs_def o_def filter_map) lemma pdevs_of_list_dense_list_of_pdevs: "pdevs_of_list (dense_list_of_pdevs x) = x" by (auto simp: pdevs_apply_pdevs_of_list dense_list_of_pdevs_def pdevs_eqI) lemma pdevs_val_sum_list: "pdevs_val (λ_. c) X = c *⇩R sum_list (map snd (list_of_pdevs X))" by (auto simp: pdevs_val_sum sum_list_list_of_pdevs pdevs_val_const_pdevs_of_list[symmetric] pdevs_of_list_dense_list_of_pdevs) lemma list_of_pdevs_all_nonzero: "list_all (λx. x ≠ 0) (map snd (list_of_pdevs xs))" by (auto simp: list_of_pdevs_def list_all_iff) lemma list_of_pdevs_nonzero: "x ∈ set (map snd (list_of_pdevs xs)) ⟹ x ≠ 0" by (auto simp: list_of_pdevs_def) lemma pdevs_of_list_scaleR_0[simp]: fixes xs::"'a::real_vector list" shows "pdevs_of_list (map ((*⇩R) 0) xs) = zero_pdevs" by (auto simp: pdevs_apply_pdevs_of_list intro!: pdevs_eqI) lemma degree_pdevs_of_list_scaleR: "degree (pdevs_of_list (map ((*⇩R) c) xs)) = (if c ≠ 0 then degree (pdevs_of_list xs) else 0)" by (auto simp: pdevs_apply_pdevs_of_list intro!: degree_cong) lemma list_of_pdevs_eq: "rev (list_of_pdevs X) = (filter ((≠) 0 o snd) (map (λi. (i, pdevs_apply X i)) [0..<degree X]))" (is "_ = filter ?P (map ?f ?xs)") using map_filter[of ?f ?P ?xs] by (auto simp: list_of_pdevs_def o_def sorted_list_of_pdevs_domain_eq rev_map) lemma sum_list_take_pdevs_val_eq: "sum_list (take d xs) = pdevs_val (λi. if i < d then 1 else 0) (pdevs_of_list xs)" proof - have "sum_list (take d xs) = 1 *⇩R sum_list (take d xs)" by simp also note pdevs_val_const_pdevs_of_list[symmetric] also have "pdevs_val (λ_. 1) (pdevs_of_list (take d xs)) = pdevs_val (λi. if i < d then 1 else 0) (pdevs_of_list xs)" by (auto simp: pdevs_apply_pdevs_of_list split: if_split_asm intro!: pdevs_val_eqI) finally show ?thesis . qed lemma zero_in_range_pdevs_apply[intro, simp]: fixes X::"'a::real_vector pdevs" shows "0 ∈ range (pdevs_apply X)" by (metis degree_gt less_irrefl rangeI) lemma dense_list_in_range: "x ∈ set (dense_list_of_pdevs X) ⟹ x ∈ range (pdevs_apply X)" by (auto simp: dense_list_of_pdevs_def) lemma not_in_dense_list_zeroD: assumes "pdevs_apply X i ∉ set (dense_list_of_pdevs X)" shows "pdevs_apply X i = 0" proof (rule ccontr) assume "pdevs_apply X i ≠ 0" hence "i < degree X" by (rule degree_gt) thus False using assms by (auto simp: dense_list_of_pdevs_def) qed lemma list_all_list_of_pdevsI: assumes "⋀i. i ∈ pdevs_domain X ⟹ P (pdevs_apply X i)" shows "list_all (λx. P x) (map snd (list_of_pdevs X))" using assms by (auto simp: list_all_iff list_of_pdevs_def) lemma pdevs_of_list_map_scaleR: "pdevs_of_list (map (scaleR r) xs) = scaleR_pdevs r (pdevs_of_list xs)" by (auto intro!: pdevs_eqI simp: pdevs_apply_pdevs_of_list) lemma map_permI: assumes "xs <~~> ys" shows "map f xs <~~> map f ys" using assms by induct auto lemma rev_perm: "rev xs <~~> ys ⟷ xs <~~> ys" by (metis perm.trans perm_rev rev_rev_ident) lemma list_of_pdevs_perm_filter_nonzero: "map snd (list_of_pdevs X) <~~> (filter ((≠) 0) (dense_list_of_pdevs X))" proof - have zip_map: "zip [0..<degree X] (dense_list_of_pdevs X) = map (λi. (i, pdevs_apply X i)) [0..<degree X]" by (auto simp: dense_list_of_pdevs_def intro!: nth_equalityI) have "rev (list_of_pdevs X) <~~> filter ((≠) 0 o snd) (zip [0..<degree X] (dense_list_of_pdevs X))" by (auto simp: list_of_pdevs_eq o_def zip_map) from map_permI[OF this, of snd] have "map snd (list_of_pdevs X) <~~> map snd (filter ((≠) 0 ∘ snd) (zip [0..<degree X] (dense_list_of_pdevs X)))" by (simp add: rev_map[symmetric] rev_perm) also have "map snd (filter ((≠) 0 ∘ snd) (zip [0..<degree X] (dense_list_of_pdevs X))) = filter ((≠) 0) (dense_list_of_pdevs X)" using map_filter[of snd "(≠) 0" "(zip [0..<degree X] (dense_list_of_pdevs X))"] by (simp add: o_def dense_list_of_pdevs_def) finally show ?thesis . qed lemma pdevs_val_filter: assumes mem: "e ∈ UNIV → I" assumes "0 ∈ I" obtains e' where "pdevs_val e (pdevs_of_list (filter p xs)) = pdevs_val e' (pdevs_of_list xs)" "e' ∈ UNIV → I" unfolding pdevs_val_filter_pdevs_eval proof - have "(λ_::nat. 0) ∈ UNIV → I" using assms by simp have "pdevs_val e (pdevs_of_list (filter p xs)) = pdevs_val e (pdevs_of_list (filter p xs)) + pdevs_val (λ_. 0) (pdevs_of_list (filter (Not o p) xs))" by (simp add: pdevs_val_sum) also from pdevs_val_pdevs_of_list_append[OF ‹e ∈ _› ‹(λ_. 0) ∈ _›] obtain e' where "e' ∈ UNIV → I" "… = pdevs_val e' (pdevs_of_list (filter p xs @ filter (Not o p) xs))" by metis note this(2) also from pdevs_val_perm[OF partition_permI ‹e' ∈ _›] obtain e'' where "… = pdevs_val e'' (pdevs_of_list xs)" "e'' ∈ UNIV → I" by metis note this(1) finally show ?thesis using ‹e'' ∈ _› .. qed lemma pdevs_val_of_list_of_pdevs: assumes "e ∈ UNIV → I" assumes "0 ∈ I" obtains e' where "pdevs_val e (pdevs_of_list (map snd (list_of_pdevs X))) = pdevs_val e' X" "e' ∈ UNIV → I" proof - obtain e' where "e' ∈ UNIV → I" and "pdevs_val e (pdevs_of_list (map snd (list_of_pdevs X))) = pdevs_val e' (pdevs_of_list (filter ((≠) 0) (dense_list_of_pdevs X)))" by (rule pdevs_val_perm[OF list_of_pdevs_perm_filter_nonzero assms(1)]) note this(2) also from pdevs_val_filter[OF ‹e' ∈ _› ‹0 ∈ I›, of "(≠) 0" "dense_list_of_pdevs X"] obtain e'' where "e'' ∈ UNIV → I" and "… = pdevs_val e'' (pdevs_of_list (dense_list_of_pdevs X))" by metis note this(2) also have "… = pdevs_val e'' X" by (simp add: pdevs_of_list_dense_list_of_pdevs) finally show ?thesis using ‹e'' ∈ UNIV → I› .. qed lemma pdevs_val_of_list_of_pdevs2: assumes "e ∈ UNIV → I" obtains e' where "pdevs_val e X = pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs X)))" "e' ∈ UNIV → I" proof - from list_of_pdevs_perm_filter_nonzero[of X] have perm: "(filter ((≠) 0) (dense_list_of_pdevs X)) <~~> map snd (list_of_pdevs X)" by (simp add: perm_sym) have "pdevs_val e X = pdevs_val e (pdevs_of_list (dense_list_of_pdevs X))" by (simp add: pdevs_of_list_dense_list_of_pdevs) also from pdevs_val_partition[OF ‹e ∈ _›, of "dense_list_of_pdevs X" "(≠) 0"] obtain f g where "f ∈ UNIV → I" "g ∈ UNIV → I" "… = pdevs_val f (pdevs_of_list (filter ((≠) 0) (dense_list_of_pdevs X))) + pdevs_val g (pdevs_of_list (filter (Not ∘ (≠) 0) (dense_list_of_pdevs X)))" (is "_ = ?f + ?g") by metis note this(3) also have "pdevs_of_list [x←dense_list_of_pdevs X . x = 0] = zero_pdevs" by (auto intro!: pdevs_eqI simp: pdevs_apply_pdevs_of_list dest!: nth_mem) hence "?g = 0" by (auto simp: o_def ) also obtain e' where "e' ∈ UNIV → I" and "?f = pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs X)))" by (rule pdevs_val_perm[OF perm ‹f ∈ _›]) note this(2) finally show ?thesis using ‹e' ∈ UNIV → I› by (auto intro!: that) qed lemma dense_list_of_pdevs_scaleR: "r ≠ 0 ⟹ map ((*⇩R) r) (dense_list_of_pdevs x) = dense_list_of_pdevs (scaleR_pdevs r x)" by (auto simp: dense_list_of_pdevs_def) lemma degree_pdevs_of_list_eq: "(⋀x. x ∈ set xs ⟹ x ≠ 0) ⟹ degree (pdevs_of_list xs) = length xs" by (cases xs) (auto simp add: pdevs_apply_pdevs_of_list nth_Cons intro!: degree_eqI split: nat.split) lemma dense_list_of_pdevs_pdevs_of_list: "(⋀x. x ∈ set xs ⟹ x ≠ 0) ⟹ dense_list_of_pdevs (pdevs_of_list xs) = xs" by (auto simp: dense_list_of_pdevs_def degree_pdevs_of_list_eq pdevs_apply_pdevs_of_list intro!: nth_equalityI) lemma pdevs_of_list_sum: assumes "distinct xs" assumes "e ∈ UNIV → I" obtains f where "f ∈ UNIV → I" "pdevs_val e (pdevs_of_list xs) = (∑P∈set xs. f P *⇩R P)" proof - define f where "f X = e (the (map_of (zip xs [0..<length xs]) X))" for X from assms have "f ∈ UNIV → I" by (auto simp: f_def) moreover have "pdevs_val e (pdevs_of_list xs) = (∑P∈set xs. f P *⇩R P)" by (auto simp add: pdevs_val_zip f_def assms sum_list_distinct_conv_sum_set[symmetric] in_set_zip map_of_zip_upto2_length_eq_nth intro!: sum_list_nth_eqI) ultimately show ?thesis .. qed lemma pdevs_domain_eq_pdevs_of_list: assumes nz: "⋀x. x ∈ set (xs) ⟹ x ≠ 0" shows "pdevs_domain (pdevs_of_list xs) = {0..<length xs}" using nz by (auto simp: pdevs_apply_pdevs_of_list split: if_split_asm) lemma length_list_of_pdevs_pdevs_of_list: assumes nz: "⋀x. x ∈ set xs ⟹ x ≠ 0" shows "length (list_of_pdevs (pdevs_of_list xs)) = length xs" using nz by (auto simp: list_of_pdevs_def pdevs_domain_eq_pdevs_of_list) lemma nth_list_of_pdevs_pdevs_of_list: assumes nz: "⋀x. x ∈ set xs ⟹ x ≠ 0" assumes l: "n < length xs" shows "list_of_pdevs (pdevs_of_list xs) ! n = ((length xs - Suc n), xs ! (length xs - Suc n))" using nz l by (auto simp: list_of_pdevs_def pdevs_domain_eq_pdevs_of_list rev_nth pdevs_apply_pdevs_of_list) lemma list_of_pdevs_pdevs_of_list_eq: "(⋀x. x ∈ set xs ⟹ x ≠ 0) ⟹ list_of_pdevs (pdevs_of_list xs) = zip (rev [0..<length xs]) (rev xs)" by (auto simp: nth_list_of_pdevs_pdevs_of_list length_list_of_pdevs_pdevs_of_list rev_nth intro!: nth_equalityI) lemma sum_list_filter_list_of_pdevs_of_list: fixes xs::"'a::comm_monoid_add list" assumes "⋀x. x ∈ set xs ⟹ x ≠ 0" shows "sum_list (filter p (map snd (list_of_pdevs (pdevs_of_list xs)))) = sum_list (filter p xs)" using assms by (auto simp: list_of_pdevs_pdevs_of_list_eq rev_filter[symmetric]) lemma sum_list_partition: fixes xs::"'a::comm_monoid_add list" shows "sum_list (filter p xs) + sum_list (filter (Not o p) xs) = sum_list xs" by (induct xs) (auto simp: ac_simps) subsection ‹2d zonotopes› definition "prod_of_pdevs x y = binop_pdevs Pair x y" lemma apply_pdevs_prod_of_pdevs[simp]: "pdevs_apply (prod_of_pdevs x y) i = (pdevs_apply x i, pdevs_apply y i)" unfolding prod_of_pdevs_def by (simp add: zero_prod_def) lemma pdevs_domain_prod_of_pdevs[simp]: "pdevs_domain (prod_of_pdevs x y) = pdevs_domain x ∪ pdevs_domain y" by (auto simp: zero_prod_def) lemma pdevs_val_prod_of_pdevs[simp]: "pdevs_val e (prod_of_pdevs x y) = (pdevs_val e x, pdevs_val e y)" proof - have "pdevs_val e x = (∑i∈pdevs_domain x ∪ pdevs_domain y. e i *⇩R pdevs_apply x i)" (is "_ = ?x") unfolding pdevs_val_pdevs_domain by (rule sum.mono_neutral_cong_left) auto moreover have "pdevs_val e y = (∑i∈pdevs_domain x ∪ pdevs_domain y. e i *⇩R pdevs_apply y i)" (is "_ = ?y") unfolding pdevs_val_pdevs_domain by (rule sum.mono_neutral_cong_left) auto ultimately have "(pdevs_val e x, pdevs_val e y) = (?x, ?y)" by auto also have "… = pdevs_val e (prod_of_pdevs x y)" by (simp add: sum_prod pdevs_val_pdevs_domain) finally show ?thesis by simp qed definition prod_of_aforms (infixr "×⇩a" 80) where "prod_of_aforms x y = ((fst x, fst y), prod_of_pdevs (snd x) (snd y))" subsection ‹Intervals› definition One_pdevs_raw::"nat ⇒ 'a::executable_euclidean_space" where "One_pdevs_raw i = (if i < length (Basis_list::'a list) then Basis_list ! i else 0)" lemma zeros_One_pdevs_raw: "One_pdevs_raw -` {0::'a::executable_euclidean_space} = {length (Basis_list::'a list)..}" by (auto simp: One_pdevs_raw_def nonzero_Basis split: if_split_asm dest!: nth_mem) lemma nonzeros_One_pdevs_raw: "{i. One_pdevs_raw i ≠ (0::'a::executable_euclidean_space)} = - {length (Basis_list::'a list)..}" using zeros_One_pdevs_raw by blast lift_definition One_pdevs::"'a::executable_euclidean_space pdevs" is One_pdevs_raw by (auto simp: nonzeros_One_pdevs_raw) lemma pdevs_apply_One_pdevs[simp]: "pdevs_apply One_pdevs i = (if i < length (Basis_list::'a::executable_euclidean_space list) then Basis_list ! i else 0::'a)" by transfer (simp add: One_pdevs_raw_def) lemma Max_Collect_less_nat: "Max {i::nat. i < k} = (if k = 0 then Max {} else k - 1)" by (auto intro!: Max_eqI) lemma degree_One_pdevs[simp]: "degree (One_pdevs::'a pdevs) = length (Basis_list::'a::executable_euclidean_space list)" by (auto simp: degree_eq_Suc_max Basis_list_nth_nonzero Max_Collect_less_nat intro!: Max_eqI DIM_positive) definition inner_scaleR_pdevs::"'a::euclidean_space ⇒ 'a pdevs ⇒ 'a pdevs" where "inner_scaleR_pdevs b x = unop_pdevs (λx. (b ∙ x) *⇩R x) x" lemma pdevs_apply_inner_scaleR_pdevs[simp]: "pdevs_apply (inner_scaleR_pdevs a x) i = (a ∙ (pdevs_apply x i)) *⇩R (pdevs_apply x i)" by (simp add: inner_scaleR_pdevs_def) lemma degree_inner_scaleR_pdevs_le: "degree (inner_scaleR_pdevs (l::'a::executable_euclidean_space) One_pdevs) ≤ degree (One_pdevs::'a pdevs)" by (rule degree_leI) (auto simp: inner_scaleR_pdevs_def One_pdevs_raw_def) definition "pdevs_of_ivl l u = scaleR_pdevs (1/2) (inner_scaleR_pdevs (u - l) One_pdevs)" lemma degree_pdevs_of_ivl_le: "degree (pdevs_of_ivl l u::'a::executable_euclidean_space pdevs) ≤ DIM('a)" using degree_inner_scaleR_pdevs_le by (simp add: pdevs_of_ivl_def) lemma pdevs_apply_pdevs_of_ivl: defines "B ≡ Basis_list::'a::executable_euclidean_space list" shows "pdevs_apply (pdevs_of_ivl l u) i = (if i < length B then ((u - l)∙(B!i)/2)*⇩R(B!i) else 0)" by (auto simp: pdevs_of_ivl_def B_def) lemma deg_length_less_imp[simp]: "k < degree (pdevs_of_ivl l u::'a::executable_euclidean_space pdevs) ⟹ k < length (Basis_list::'a list)" by (metis (no_types, hide_lams) degree_One_pdevs degree_inner_scaleR_pdevs_le degree_scaleR_pdevs dual_order.strict_trans length_Basis_list_pos nat_neq_iff not_le pdevs_of_ivl_def) lemma tdev_pdevs_of_ivl: "tdev (pdevs_of_ivl l u) = ¦u - l¦ /⇩R 2" proof - have "tdev (pdevs_of_ivl l u) = (∑i <degree (pdevs_of_ivl l u). ¦pdevs_apply (pdevs_of_ivl l u) i¦)" by (auto simp: tdev_def) also have "… = (∑i = 0..<length (Basis_list::'a list). ¦pdevs_apply (pdevs_of_ivl l u) i¦)" using degree_pdevs_of_ivl_le[of l u] by (intro sum.mono_neutral_cong_left) auto also have "… = (∑i = 0..<length (Basis_list::'a list). ¦((u - l) ∙ Basis_list ! i / 2) *⇩R Basis_list ! i¦)" by (auto simp: pdevs_apply_pdevs_of_ivl) also have "… = (∑b ← Basis_list. ¦((u - l) ∙ b / 2) *⇩R b¦)" by (auto simp: sum_list_sum_nth) also have "… = (∑b∈Basis. ¦((u - l) ∙ b / 2) *⇩R b¦)" by (auto simp: sum_list_distinct_conv_sum_set) also have "… = ¦u - l¦ /⇩R 2" by (subst euclidean_representation[symmetric, of "¦u - l¦ /⇩R 2"]) (simp add: abs_inner abs_scaleR) finally show ?thesis . qed definition "aform_of_ivl l u = ((l + u)/⇩R2, pdevs_of_ivl l u)" definition "aform_of_point x = aform_of_ivl x x" lemma Elem_affine_of_ivl_le: assumes "e ∈ UNIV → {-1 .. 1}" assumes "l ≤ u" shows "l ≤ aform_val e (aform_of_ivl l u)" proof - have "l = (1 / 2) *⇩R l + (1 / 2) *⇩R l" by (simp add: scaleR_left_distrib[symmetric]) also have "… = (l + u)/⇩R2 - tdev (pdevs_of_ivl l u)" by (auto simp: assms tdev_pdevs_of_ivl algebra_simps) also have "… ≤ aform_val e (aform_of_ivl l u)" using abs_pdevs_val_le_tdev[OF assms(1), of "pdevs_of_ivl l u"] by (auto simp: aform_val_def aform_of_ivl_def minus_le_iff dest!: abs_le_D2) finally show ?thesis . qed lemma Elem_affine_of_ivl_ge: assumes "e ∈ UNIV → {-1 .. 1}" assumes "l ≤ u" shows "aform_val e (aform_of_ivl l u) ≤ u" proof - have "aform_val e (aform_of_ivl l u) ≤ (l + u)/⇩R2 + tdev (pdevs_of_ivl l u)" using abs_pdevs_val_le_tdev[OF assms(1), of "pdevs_of_ivl l u"] by (auto simp: aform_val_def aform_of_ivl_def minus_le_iff dest!: abs_le_D1) also have "… = (1 / 2) *⇩R u + (1 / 2) *⇩R u" by (auto simp: assms tdev_pdevs_of_ivl algebra_simps) also have "… = u" by (simp add: scaleR_left_distrib[symmetric]) finally show ?thesis . qed lemma map_of_zip_upto_length_eq_nth: assumes "i < length B" assumes "d = length B" shows "(map_of (zip [0..<d] B) i) = Some (B ! i)" proof - have "length [0..<length B] = length B" by simp from map_of_zip_is_Some[OF this, of i] assms have "map_of (zip [0..<length B] B) i = Some (B ! i)" by (auto simp: in_set_zip) thus ?thesis by (simp add: assms) qed lemma in_ivl_affine_of_ivlE: assumes "k ∈ {l .. u}" obtains e where "e ∈ UNIV → {-1 .. 1}" "k = aform_val e (aform_of_ivl l u)" proof atomize_elim define e where [abs_def]: "e i = (let b = if i <length (Basis_list::'a list) then (the (map_of (zip [0..<length (Basis_list::'a list)] (Basis_list::'a list)) i)) else 0 in ((k - (l + u) /⇩R 2) ∙ b) / (((u - l) /⇩R 2) ∙ b))" for i let ?B = "Basis_list::'a list" have "k = (1 / 2) *⇩R (l + u) + (∑b ∈ Basis. (if (u - l) ∙ b = 0 then 0 else ((k - (1 / 2) *⇩R (l + u)) ∙ b)) *⇩R b)" (is "_ = _ + ?dots") using assms by (force simp add: algebra_simps eucl_le[where 'a='a] intro!: euclidean_eqI[where 'a='a]) also have "?dots = (∑b ∈ Basis. (if (u - l) ∙ b = 0 then 0 else ((k - (1 / 2) *⇩R (l + u)) ∙ b) *⇩R b))" by (auto intro!: sum.cong) also have "… = (∑b ← ?B. (if (u - l) ∙ b = 0 then 0 else ((k - (1 / 2) *⇩R (l + u)) ∙ b) *⇩R b))" by (auto simp: sum_list_distinct_conv_sum_set) also have "… = (∑i = 0..<length ?B. (if (u - l) ∙ ?B ! i = 0 then 0 else ((k - (1 / 2) *⇩R (l + u)) ∙ ?B ! i) *⇩R ?B ! i))" by (auto simp: sum_list_sum_nth) also have "… = (∑i = 0..<degree (inner_scaleR_pdevs (u - l) One_pdevs). (if (u - l) ∙ Basis_list ! i = 0 then 0 else ((k - (1 / 2) *⇩R (l + u)) ∙ Basis_list ! i) *⇩R Basis_list ! i))" using degree_inner_scaleR_pdevs_le[of "u - l"] by (intro sum.mono_neutral_cong_right) (auto dest!: degree) also have "(1 / 2) *⇩R (l + u) + (∑i = 0..<degree (inner_scaleR_pdevs (u - l) One_pdevs). (if (u - l) ∙ Basis_list ! i = 0 then 0 else ((k - (1 / 2) *⇩R (l + u)) ∙ Basis_list ! i) *⇩R Basis_list ! i)) = aform_val e (aform_of_ivl l u)" using degree_inner_scaleR_pdevs_le[of "u - l"] by (auto simp: aform_val_def aform_of_ivl_def pdevs_of_ivl_def map_of_zip_upto_length_eq_nth e_def Let_def pdevs_val_sum intro!: sum.cong) finally have "k = aform_val e (aform_of_ivl l u)" . moreover { fix k l u::real assume *: "l ≤ k" "k ≤ u" let ?m = "l / 2 + u / 2" have "¦k - ?m¦ ≤ ¦if k ≤ ?m then ?m - l else u - ?m¦" using * by auto also have "… ≤ ¦u / 2 - l / 2¦" by (auto simp: abs_real_def) finally have "¦k - (l / 2 + u / 2)¦ ≤ ¦u / 2 - l/2¦" . } note midpoint_abs = this have "e ∈ UNIV → {- 1..1}" using assms unfolding e_def Let_def by (intro Pi_I divide_atLeastAtMost_1_absI) (auto simp: map_of_zip_upto_length_eq_nth eucl_le[where 'a='a] divide_le_eq_1 not_less inner_Basis algebra_simps intro!: midpoint_abs dest!: nth_mem) ultimately show "∃e. e ∈ UNIV → {- 1..1} ∧ k = aform_val e (aform_of_ivl l u)" by blast qed lemma Inf_aform_aform_of_ivl: assumes "l ≤ u" shows "Inf_aform (aform_of_ivl l u) = l" using assms by (auto simp: Inf_aform_def aform_of_ivl_def tdev_pdevs_of_ivl abs_diff_eq1 algebra_simps) (metis field_sum_of_halves scaleR_add_left scaleR_one) lemma Sup_aform_aform_of_ivl: assumes "l ≤ u" shows "Sup_aform (aform_of_ivl l u) = u" using assms by (auto simp: Sup_aform_def aform_of_ivl_def tdev_pdevs_of_ivl abs_diff_eq1 algebra_simps) (metis field_sum_of_halves scaleR_add_left scaleR_one) lemma Affine_aform_of_ivl: "a ≤ b ⟹ Affine (aform_of_ivl a b) = {a .. b}" by (force simp: Affine_def valuate_def intro!: Elem_affine_of_ivl_ge Elem_affine_of_ivl_le elim!: in_ivl_affine_of_ivlE) end
section ‹Operations on Expressions› theory Floatarith_Expression imports "HOL-Decision_Procs.Approximation" Affine_Arithmetic_Auxiliarities Executable_Euclidean_Space begin text ‹Much of this could move to the distribution...› subsection ‹Approximating Expression*s*› unbundle floatarith_notation text ‹\label{sec:affineexpr}› primrec interpret_floatariths :: "floatarith list ⇒ real list ⇒ real list" where "interpret_floatariths [] vs = []" | "interpret_floatariths (a#bs) vs = interpret_floatarith a vs#interpret_floatariths bs vs" lemma length_interpret_floatariths[simp]: "length (interpret_floatariths fas xs) = length fas" by (induction fas) auto lemma interpret_floatariths_nth[simp]: "interpret_floatariths fas xs ! n = interpret_floatarith (fas ! n) xs" if "n < length fas" using that by (induction fas arbitrary: n) (auto simp: nth_Cons split: nat.splits) abbreviation "einterpret ≡ λfas vs. eucl_of_list (interpret_floatariths fas vs)" subsection ‹Syntax› syntax interpret_floatarith::"floatarith ⇒ real list ⇒ real" instantiation floatarith :: "{plus, minus, uminus, times, inverse, zero, one}" begin definition "- f = Minus f" lemma interpret_floatarith_uminus[simp]: "interpret_floatarith (- f) xs = - interpret_floatarith f xs" by (auto simp: uminus_floatarith_def) definition "f + g = Add f g" lemma interpret_floatarith_plus[simp]: "interpret_floatarith (f + g) xs = interpret_floatarith f xs + interpret_floatarith g xs" by (auto simp: plus_floatarith_def) definition "f - g = Add f (Minus g)" lemma interpret_floatarith_minus[simp]: "interpret_floatarith (f - g) xs = interpret_floatarith f xs - interpret_floatarith g xs" by (auto simp: minus_floatarith_def) definition "inverse f = Inverse f" lemma interpret_floatarith_inverse[simp]: "interpret_floatarith (inverse f) xs = inverse (interpret_floatarith f xs)" by (auto simp: inverse_floatarith_def) definition "f * g = Mult f g" lemma interpret_floatarith_times[simp]: "interpret_floatarith (f * g) xs = interpret_floatarith f xs * interpret_floatarith g xs" by (auto simp: times_floatarith_def) definition "f div g = f * Inverse g" lemma interpret_floatarith_divide[simp]: "interpret_floatarith (f div g) xs = interpret_floatarith f xs / interpret_floatarith g xs" by (auto simp: divide_floatarith_def inverse_eq_divide) definition "1 = Num 1" lemma interpret_floatarith_one[simp]: "interpret_floatarith 1 xs = 1" by (auto simp: one_floatarith_def) definition "0 = Num 0" lemma interpret_floatarith_zero[simp]: "interpret_floatarith 0 xs = 0" by (auto simp: zero_floatarith_def) instance proof qed end subsection ‹Derived symbols› definition "R⇩e r = (case quotient_of r of (n, d) ⇒ Num (of_int n) / Num (of_int d))" declare [[coercion R⇩e ]] lemma interpret_R⇩e[simp]: "interpret_floatarith (R⇩e x) xs = real_of_rat x" by (auto simp: R⇩e_def of_rat_divide dest!: quotient_of_div split: prod.splits) definition "Sin x = Cos ((Pi * (Num (Float 1 (-1)))) - x)" lemma interpret_floatarith_Sin[simp]: "interpret_floatarith (Sin x) vs = sin (interpret_floatarith x vs)" by (auto simp: Sin_def approximation_preproc_floatarith(11)) definition "Half x = Mult (Num (Float 1 (-1))) x" lemma interpret_Half[simp]: "interpret_floatarith (Half x) xs = interpret_floatarith x xs / 2" by (auto simp: Half_def) definition "Tan x = (Sin x) / (Cos x)" lemma interpret_floatarith_Tan[simp]: "interpret_floatarith (Tan x) vs = tan (interpret_floatarith x vs)" by (auto simp: Tan_def approximation_preproc_floatarith(12) inverse_eq_divide) primrec Sum⇩e where "Sum⇩e f [] = 0" | "Sum⇩e f (x#xs) = f x + Sum⇩e f xs" lemma interpret_floatarith_Sum⇩e[simp]: "interpret_floatarith (Sum⇩e f x) vs = (∑i←x. interpret_floatarith (f i) vs)" by (induction x) auto definition Norm where "Norm is = Sqrt (Sum⇩e (λi. i * i) is)" lemma interpret_floatarith_norm[simp]: assumes [simp]: "length x = DIM('a)" shows "interpret_floatarith (Norm x) vs = norm (einterpret x vs::'a::executable_euclidean_space)" apply (auto simp: Norm_def norm_eq_sqrt_inner) apply (subst euclidean_inner[where 'a='a]) apply (auto simp: power2_eq_square[symmetric] ) apply (subst sum_list_Basis_list[symmetric]) apply (rule sum_list_nth_eqI) by (auto simp: in_set_zip eucl_of_list_inner) notation floatarith.Power (infixr "^⇩e" 80) subsection ‹Constant Folding› fun dest_Num_fa where "dest_Num_fa (floatarith.Num x) = Some x" | "dest_Num_fa _ = None" fun_cases dest_Num_fa_None: "dest_Num_fa fa = None" and dest_Num_fa_Some: "dest_Num_fa fa = Some x" fun fold_const_fa where "fold_const_fa (Add fa1 fa2) = (let (ffa1, ffa2) = (fold_const_fa fa1, fold_const_fa fa2) in case (dest_Num_fa ffa1, dest_Num_fa (ffa2)) of (Some a, Some b) ⇒ Num (a + b) | (Some a, None) ⇒ (if a = 0 then ffa2 else Add (Num a) ffa2) | (None, Some a) ⇒ (if a = 0 then ffa1 else Add ffa1 (Num a)) | (None, None) ⇒ Add ffa1 ffa2)" | "fold_const_fa (Minus a) = (case (fold_const_fa a) of (Num x) ⇒ Num (-x) | x ⇒ Minus x)" | "fold_const_fa (Mult fa1 fa2) = (let (ffa1, ffa2) = (fold_const_fa fa1, fold_const_fa fa2) in case (dest_Num_fa ffa1, dest_Num_fa (ffa2)) of (Some a, Some b) ⇒ Num (a * b) | (Some a, None) ⇒ (if a = 0 then Num 0 else if a = 1 then ffa2 else Mult (Num a) ffa2) | (None, Some a) ⇒ (if a = 0 then Num 0 else if a = 1 then ffa1 else Mult ffa1 (Num a)) | (None, None) ⇒ Mult ffa1 ffa2)" | "fold_const_fa (Inverse a) = Inverse (fold_const_fa a)" | "fold_const_fa (Abs a) = (case (fold_const_fa a) of (Num x) ⇒ Num (abs x) | x ⇒ Abs x)" | "fold_const_fa (Max a b) = (case (fold_const_fa a, fold_const_fa b) of (Num x, Num y) ⇒ Num (max x y) | (x, y) ⇒ Max x y)" | "fold_const_fa (Min a b) = (case (fold_const_fa a, fold_const_fa b) of (Num x, Num y) ⇒ Num (min x y) | (x, y) ⇒ Min x y)" | "fold_const_fa (Floor a) = (case (fold_const_fa a) of (Num x) ⇒ Num (floor_fl x) | x ⇒ Floor x)" | "fold_const_fa (Power a b) = (case (fold_const_fa a) of (Num x) ⇒ Num (x ^ b) | x ⇒ Power x b)" | "fold_const_fa (Cos a) = Cos (fold_const_fa a)" | "fold_const_fa (Arctan a) = Arctan (fold_const_fa a)" | "fold_const_fa (Sqrt a) = Sqrt (fold_const_fa a)" | "fold_const_fa (Exp a) = Exp (fold_const_fa a)" | "fold_const_fa (Ln a) = Ln (fold_const_fa a)" | "fold_const_fa (Powr a b) = Powr (fold_const_fa a) (fold_const_fa b)" | "fold_const_fa Pi = Pi" | "fold_const_fa (Var v) = Var v" | "fold_const_fa (Num x) = Num x" fun_cases fold_const_fa_Num: "fold_const_fa fa = Num y" and fold_const_fa_Add: "fold_const_fa fa = Add x y" and fold_const_fa_Minus: "fold_const_fa fa = Minus y" lemma fold_const_fa[simp]: "interpret_floatarith (fold_const_fa fa) xs = interpret_floatarith fa xs" by (induction fa) (auto split!: prod.splits floatarith.splits option.splits elim!: dest_Num_fa_None dest_Num_fa_Some simp: max_def min_def floor_fl_def) subsection ‹Free Variables› primrec max_Var_floatarith where― ‹TODO: include bound in predicate› "max_Var_floatarith (Add a b) = max (max_Var_floatarith a) (max_Var_floatarith b)" | "max_Var_floatarith (Mult a b) = max (max_Var_floatarith a) (max_Var_floatarith b)" | "max_Var_floatarith (Inverse a) = max_Var_floatarith a" | "max_Var_floatarith (Minus a) = max_Var_floatarith a" | "max_Var_floatarith (Num a) = 0" | "max_Var_floatarith (Var i) = Suc i" | "max_Var_floatarith (Cos a) = max_Var_floatarith a" | "max_Var_floatarith (floatarith.Arctan a) = max_Var_floatarith a" | "max_Var_floatarith (Abs a) = max_Var_floatarith a" | "max_Var_floatarith (floatarith.Max a b) = max (max_Var_floatarith a) (max_Var_floatarith b)" | "max_Var_floatarith (floatarith.Min a b) = max (max_Var_floatarith a) (max_Var_floatarith b)" | "max_Var_floatarith (floatarith.Pi) = 0" | "max_Var_floatarith (Sqrt a) = max_Var_floatarith a" | "max_Var_floatarith (Exp a) = max_Var_floatarith a" | "max_Var_floatarith (Powr a b) = max (max_Var_floatarith a) (max_Var_floatarith b)" | "max_Var_floatarith (floatarith.Ln a) = max_Var_floatarith a" | "max_Var_floatarith (Power a n) = max_Var_floatarith a" | "max_Var_floatarith (Floor a) = max_Var_floatarith a" primrec max_Var_floatariths where "max_Var_floatariths [] = 0" | "max_Var_floatariths (x#xs) = max (max_Var_floatarith x) (max_Var_floatariths xs)" primrec max_Var_form where "max_Var_form (Conj a b) = max (max_Var_form a) (max_Var_form b)" | "max_Var_form (Disj a b) = max (max_Var_form a) (max_Var_form b)" | "max_Var_form (Less a b) = max (max_Var_floatarith a) (max_Var_floatarith b)" | "max_Var_form (LessEqual a b) = max (max_Var_floatarith a) (max_Var_floatarith b)" | "max_Var_form (Bound a b c d) = linorder_class.Max {max_Var_floatarith a,max_Var_floatarith b, max_Var_floatarith c, max_Var_form d}" | "max_Var_form (AtLeastAtMost a b c) = linorder_class.Max {max_Var_floatarith a,max_Var_floatarith b, max_Var_floatarith c}" | "max_Var_form (Assign a b c) = linorder_class.Max {max_Var_floatarith a,max_Var_floatarith b, max_Var_form c}" lemma interpret_floatarith_eq_take_max_VarI: assumes "take (max_Var_floatarith ra) ys = take (max_Var_floatarith ra) zs" shows "interpret_floatarith ra ys = interpret_floatarith ra zs" using assms by (induct ra) (auto dest!: take_max_eqD simp: take_Suc_eq split: if_split_asm) lemma interpret_floatariths_eq_take_max_VarI: assumes "take (max_Var_floatariths ea) ys = take (max_Var_floatariths ea) zs" shows "interpret_floatariths ea ys = interpret_floatariths ea zs" using assms apply (induction ea) subgoal by simp subgoal by (clarsimp) (metis interpret_floatarith_eq_take_max_VarI take_map take_max_eqD) done lemma Max_Image_distrib: includes no_floatarith_notation assumes "finite X" "X ≠ {}" shows "Max ((λx. max (f1 x) (f2 x)) ` X) = max (Max (f1 ` X)) (Max (f2 ` X))" apply (rule Max_eqI) subgoal using assms by simp subgoal for y using assms by (force intro: max.coboundedI1 max.coboundedI2 Max_ge) subgoal proof - have "Max (f1 ` X) ∈ f1 ` X" using assms by auto then obtain x1 where x1: "x1 ∈ X" "Max (f1 ` X) = f1 x1" by auto have "Max (f2 ` X) ∈ f2 ` X" using assms by auto then obtain x2 where x2: "x2 ∈ X" "Max (f2 ` X) = f2 x2" by auto show ?thesis apply (rule image_eqI[where x="if f1 x1 ≤ f2 x2 then x2 else x1"]) using x1 x2 assms apply (auto simp: max_def) apply (metis Max_ge dual_order.trans finite_imageI image_eqI assms(1)) apply (metis Max_ge dual_order.trans finite_imageI image_eqI assms(1)) done qed done lemma max_Var_floatarith_simps[simp]: "max_Var_floatarith (a / b) = max (max_Var_floatarith a) (max_Var_floatarith b)" "max_Var_floatarith (a * b) = max (max_Var_floatarith a) (max_Var_floatarith b)" "max_Var_floatarith (a + b) = max (max_Var_floatarith a) (max_Var_floatarith b)" "max_Var_floatarith (a - b) = max (max_Var_floatarith a) (max_Var_floatarith b)" "max_Var_floatarith (- b) = (max_Var_floatarith b)" by (auto simp: divide_floatarith_def times_floatarith_def plus_floatarith_def minus_floatarith_def uminus_floatarith_def) lemma max_Var_floatariths_Max: "max_Var_floatariths xs = (if set xs = {} then 0 else linorder_class.Max (max_Var_floatarith ` set xs))" by (induct xs) auto lemma max_Var_floatariths_map_plus[simp]: "max_Var_floatariths (map (λi. fa1 i + fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))" by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib) lemma max_Var_floatariths_map_times[simp]: "max_Var_floatariths (map (λi. fa1 i * fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))" by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib) lemma max_Var_floatariths_map_divide[simp]: "max_Var_floatariths (map (λi. fa1 i / fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))" by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib) lemma max_Var_floatariths_map_uminus[simp]: "max_Var_floatariths (map (λi. - fa1 i) xs) = max_Var_floatariths (map fa1 xs)" by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib) lemma max_Var_floatariths_map_const[simp]: "max_Var_floatariths (map (λi. fa) xs) = (if xs = [] then 0 else max_Var_floatarith fa)" by (auto simp: max_Var_floatariths_Max image_image image_constant_conv) lemma max_Var_floatariths_map_minus[simp]: "max_Var_floatariths (map (λi. fa1 i - fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))" by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib) primrec fresh_floatarith where "fresh_floatarith (Var y) x ⟷ (x ≠ y)" | "fresh_floatarith (Num a) x ⟷ True" | "fresh_floatarith Pi x ⟷ True" | "fresh_floatarith (Cos a) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Abs a) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Arctan a) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Sqrt a) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Exp a) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Floor a) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Power a n) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Minus a) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Ln a) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Inverse a) x ⟷ fresh_floatarith a x" | "fresh_floatarith (Add a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x" | "fresh_floatarith (Mult a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x" | "fresh_floatarith (Max a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x" | "fresh_floatarith (Min a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x" | "fresh_floatarith (Powr a b) x ⟷ fresh_floatarith a x ∧ fresh_floatarith b x" lemma fresh_floatarith_subst: fixes v::float assumes "fresh_floatarith e x" assumes "x < length vs" shows "interpret_floatarith e (vs[x:=v]) = interpret_floatarith e vs" using assms by (induction e) (auto simp: map_update) lemma fresh_floatarith_max_Var: assumes "max_Var_floatarith ea ≤ i" shows "fresh_floatarith ea i" using assms by (induction ea) auto primrec fresh_floatariths where "fresh_floatariths [] x ⟷ True" | "fresh_floatariths (a#as) x ⟷ fresh_floatarith a x ∧ fresh_floatariths as x" lemma fresh_floatariths_max_Var: assumes "max_Var_floatariths ea ≤ i" shows "fresh_floatariths ea i" using assms by (induction ea) (auto simp: fresh_floatarith_max_Var) lemma interpret_floatariths_take_eqI: assumes "take n ys = take n zs" assumes "max_Var_floatariths ea ≤ n" shows "interpret_floatariths ea ys = interpret_floatariths ea zs" by (rule interpret_floatariths_eq_take_max_VarI) (rule take_greater_eqI[OF assms]) lemma interpret_floatarith_fresh_eqI: assumes "⋀i. fresh_floatarith ea i ∨ (i < length ys ∧ i < length zs ∧ ys ! i = zs ! i)" shows "interpret_floatarith ea ys = interpret_floatarith ea zs" using assms by (induction ea) force+ lemma interpret_floatariths_fresh_eqI: assumes "⋀i. fresh_floatariths ea i ∨ (i < length ys ∧ i < length zs ∧ ys ! i = zs ! i)" shows "interpret_floatariths ea ys = interpret_floatariths ea zs" using assms apply (induction ea) subgoal by (force simp: interpret_floatarith_fresh_eqI intro: interpret_floatarith_fresh_eqI) subgoal for e ea apply clarsimp apply (auto simp: list_eq_iff_nth_eq) using interpret_floatarith_fresh_eqI by blast done lemma interpret_floatarith_max_Var_cong: assumes "⋀i. i < max_Var_floatarith f ⟹ xs ! i = ys ! i" shows "interpret_floatarith f ys = interpret_floatarith f xs" using assms by (induction f) auto lemma interpret_floatarith_fresh_cong: assumes "⋀i. ¬fresh_floatarith f i ⟹ xs ! i = ys ! i" shows "interpret_floatarith f ys = interpret_floatarith f xs" using assms by (induction f) auto lemma max_Var_floatarith_le_max_Var_floatariths: "fa ∈ set fas ⟹ max_Var_floatarith fa ≤ max_Var_floatariths fas" by (induction fas) (auto simp: nth_Cons max_def split: nat.splits) lemma max_Var_floatarith_le_max_Var_floatariths_nth: "n < length fas ⟹ max_Var_floatarith (fas ! n) ≤ max_Var_floatariths fas" by (rule max_Var_floatarith_le_max_Var_floatariths) auto lemma max_Var_floatariths_leI: assumes "⋀i. i < length xs ⟹ max_Var_floatarith (xs ! i) ≤ F" shows "max_Var_floatariths xs ≤ F" using assms by (auto simp: max_Var_floatariths_Max in_set_conv_nth) lemma fresh_floatariths_map_Var[simp]: "fresh_floatariths (map floatarith.Var xs) i ⟷ i ∉ set xs" by (induction xs) auto lemma max_Var_floatarith_fold_const_fa: "max_Var_floatarith (fold_const_fa fa) ≤ max_Var_floatarith fa" by (induction fa) (auto simp: fold_const_fa.simps split!: option.splits floatarith.splits) lemma max_Var_floatariths_fold_const_fa: "max_Var_floatariths (map fold_const_fa xs) ≤ max_Var_floatariths xs" by (auto simp: intro!: max_Var_floatariths_leI max_Var_floatarith_le_max_Var_floatariths_nth max_Var_floatarith_fold_const_fa[THEN order_trans]) lemma interpret_form_max_Var_cong: assumes "⋀i. i < max_Var_form f ⟹ xs ! i = ys ! i" shows "interpret_form f xs = interpret_form f ys" using assms by (induction f) (auto simp: interpret_floatarith_max_Var_cong[where xs=xs and ys=ys]) lemma max_Var_floatariths_lessI: "i < max_Var_floatarith (fas ! j) ⟹ j < length fas ⟹ i < max_Var_floatariths fas" by (metis leD le_trans less_le max_Var_floatarith_le_max_Var_floatariths nth_mem) lemma interpret_floatariths_max_Var_cong: assumes "⋀i. i < max_Var_floatariths f ⟹ xs ! i = ys ! i" shows "interpret_floatariths f ys = interpret_floatariths f xs" by (auto intro!: nth_equalityI interpret_floatarith_max_Var_cong assms max_Var_floatariths_lessI) lemma max_Var_floatarithimage_Var[simp]: "max_Var_floatarith ` Var ` X = Suc ` X" by force lemma max_Var_floatariths_map_Var[simp]: "max_Var_floatariths (map Var xs) = (if xs = [] then 0 else Suc (linorder_class.Max (set xs)))" by (auto simp: max_Var_floatariths_Max hom_Max_commute split: if_splits) lemma Max_atLeastLessThan_nat[simp]: "a < b ⟹ linorder_class.Max {a..<b} = b - 1" for a b::nat by (auto intro!: Max_eqI) subsection ‹Derivatives› lemma isDERIV_Power_iff: "isDERIV j (Power fa n) xs = (if n = 0 then True else isDERIV j fa xs)" by (cases n) auto lemma isDERIV_max_Var_floatarithI: assumes "isDERIV n f ys" assumes "⋀i. i < max_Var_floatarith f ⟹ xs ! i = ys ! i" shows "isDERIV n f xs" using assms proof (induction f) case (Power f n) then show ?case by (cases n) auto qed (auto simp: max_def interpret_floatarith_max_Var_cong[of _ xs ys] split: if_splits) definition isFDERIV where "isFDERIV n xs fas vs ⟷ (∀i<n. ∀j<n. isDERIV (xs ! i) (fas ! j) vs) ∧ length fas = n ∧ length xs = n" lemma isFDERIV_I: "(⋀i j. i < n ⟹ j < n ⟹ isDERIV (xs ! i) (fas ! j) vs) ⟹ length fas = n ⟹ length xs = n ⟹ isFDERIV n xs fas vs" by (auto simp: isFDERIV_def) lemma isFDERIV_isDERIV_D: "isFDERIV n xs fas vs ⟹ i < n ⟹ j < n ⟹ isDERIV (xs ! i) (fas ! j) vs" by (auto simp: isFDERIV_def) lemma isFDERIV_lengthD: "length fas = n" "length xs = n" if "isFDERIV n xs fas vs" using that by (auto simp: isFDERIV_def) lemma isFDERIV_uptD: "isFDERIV n [0..<n] fas vs ⟹ i < n ⟹ j < n ⟹ isDERIV i (fas ! j) vs" by (auto simp: isFDERIV_def) lemma isFDERIV_max_Var_congI: "isFDERIV n xs fas ws" if f: "isFDERIV n xs fas vs" and c: "(⋀i. i < max_Var_floatariths fas ⟹ vs ! i = ws ! i)" using c f by (auto simp: isFDERIV_def max_Var_floatariths_lessI intro!: isFDERIV_I isDERIV_max_Var_floatarithI[OF isFDERIV_isDERIV_D[OF f]]) lemma isFDERIV_max_Var_cong: "isFDERIV n xs fas ws ⟷ isFDERIV n xs fas vs" if c: "(⋀i. i < max_Var_floatariths fas ⟹ vs ! i = ws ! i)" using c by (auto intro: isFDERIV_max_Var_congI) lemma isDERIV_max_VarI: "i ≥ max_Var_floatarith fa ⟹ isDERIV j fa xs ⟹ isDERIV i fa xs" by (induction fa) (auto simp: isDERIV_Power_iff) lemmas max_Var_floatarith_le_max_Var_floatariths_nthI = max_Var_floatarith_le_max_Var_floatariths_nth[THEN order_trans] lemma isFDERIV_appendD1: assumes "isFDERIV (J + K) [0..<J + K] (es @ rs) xs" assumes "length es = J" assumes "length rs = K" assumes "max_Var_floatariths es ≤ J" shows "isFDERIV J [0..<J] (es) xs" unfolding isFDERIV_def apply (safe) subgoal for i j using assms apply (cases "i < length es") subgoal by (auto simp: nth_append isFDERIV_def) (metis add.commute trans_less_add2) subgoal apply (rule isDERIV_max_VarI[where j=0]) apply (rule max_Var_floatarith_le_max_Var_floatariths_nthI) apply force apply force apply force done done subgoal by (auto simp: assms) subgoal by (auto simp: assms) done lemma interpret_floatariths_Var[simp]: "interpret_floatariths (map floatarith.Var xs) vs = (map (nth vs) xs)" by (induction xs) (auto simp: ) lemma max_Var_floatariths_append[simp]: "max_Var_floatariths (xs @ ys) = max (max_Var_floatariths xs) (max_Var_floatariths ys)" by (induction xs) (auto) lemma map_nth_append_upt[simp]: assumes "a ≥ length xs" shows "map ((!) (xs @ ys)) [a..<b] = map ((!) ys) [a - length xs..<b - length xs]" using assms by (auto intro!: nth_equalityI simp: nth_append) lemma map_nth_Cons_upt[simp]: assumes "a > 0" shows "map ((!) (x # ys)) [a..<b] = map ((!) ys) [a - Suc 0..<b - Suc 0]" using assms by (auto intro!: nth_equalityI simp: nth_append) lemma map_nth_eq_self[simp]: shows "length fas = l ⟹ (map ((!) fas) [0..<l]) = fas" by (auto simp: intro!: nth_equalityI) lemma isFDERIV_appendI1: assumes "isFDERIV J [0..<J] (es) xs" assumes "⋀i j. i < J + K ⟹ j < K ⟹ isDERIV i (rs ! j) xs" assumes "length es = J" assumes "length rs = K" assumes "max_Var_floatariths es ≤ J" shows "isFDERIV (J + K) [0..<J + K] (es @ rs) xs" unfolding isFDERIV_def apply safe subgoal for i j using assms apply (cases "j < length es") subgoal apply (auto simp: nth_append isFDERIV_def) by (metis (no_types, hide_lams) isDERIV_max_VarI le_trans less_le max_Var_floatarith_le_max_Var_floatariths_nthI nat_le_linear) subgoal by (auto simp: nth_append) done subgoal by (auto simp: assms) subgoal by (auto simp: assms) done lemma matrix_matrix_mult_zero[simp]: "a ** 0 = 0" "0 ** a = 0" by (vector matrix_matrix_mult_def)+ lemma scaleR_blinfun_compose_left: "i *⇩R (A o⇩L B) = i *⇩R A o⇩L B" and scaleR_blinfun_compose_right: "i *⇩R (A o⇩L B) = A o⇩L i *⇩R B" by (auto intro!: blinfun_eqI simp: blinfun.bilinear_simps) lemma matrix_blinfun_compose: fixes A B::"(real ^ 'n) ⇒⇩L (real ^ 'n)" shows "matrix (A o⇩L B) = (matrix A) ** (matrix B)" by transfer (auto simp: matrix_compose linear_linear) lemma matrix_add_rdistrib: "((B + C) ** A) = (B ** A) + (C ** A)" by (vector matrix_matrix_mult_def sum.distrib[symmetric] field_simps) lemma matrix_scaleR_right: "r *⇩R (a::'a::real_algebra_1^'n^'m) ** b = r *⇩R (a ** b)" by (vector matrix_matrix_mult_def algebra_simps scaleR_sum_right) lemma matrix_scaleR_left: "(a::'a::real_algebra_1^'n^'m) ** r *⇩R b = r *⇩R (a ** b)" by (vector matrix_matrix_mult_def algebra_simps scaleR_sum_right) lemma bounded_bilinear_matrix_matrix_mult[bounded_bilinear]: "bounded_bilinear ((**):: ('a::{euclidean_space, real_normed_algebra_1}^'n^'m) ⇒ ('a::{euclidean_space, real_normed_algebra_1}^'p^'n) ⇒ ('a::{euclidean_space, real_normed_algebra_1}^'p^'m))" unfolding bilinear_conv_bounded_bilinear[symmetric] unfolding bilinear_def apply safe by unfold_locales (auto simp: matrix_add_ldistrib matrix_add_rdistrib matrix_scaleR_right matrix_scaleR_left) lemma norm_axis: "norm (axis ia 1::'a::{real_normed_algebra_1}^'n) = 1" by (auto simp: axis_def norm_vec_def L2_set_def if_distrib if_distribR sum.delta cong: if_cong) lemma abs_vec_nth_blinfun_apply_lemma: fixes x::"(real^'n) ⇒⇩L (real^'m)" shows "abs (vec_nth (blinfun_apply x (axis ia 1)) i) ≤ norm x" apply (rule component_le_norm_cart[THEN order_trans]) apply (rule norm_blinfun[THEN order_trans]) by (auto simp: norm_axis) lemma bounded_linear_matrix_blinfun_apply: "bounded_linear (λx::(real^'n) ⇒⇩L (real^'m). matrix (blinfun_apply x))" apply standard subgoal by (vector blinfun.bilinear_simps matrix_def) subgoal by (vector blinfun.bilinear_simps matrix_def) apply (rule exI[where x="real (CARD('n) * CARD('m))"]) apply (auto simp: matrix_def) apply (subst norm_vec_def) apply (rule L2_set_le_sum[THEN order_trans]) apply simp apply auto apply (rule sum_mono[THEN order_trans]) apply (subst norm_vec_def) apply (rule L2_set_le_sum) apply simp apply (rule sum_mono[THEN order_trans]) apply (rule sum_mono) apply simp apply (rule abs_vec_nth_blinfun_apply_lemma) apply (simp add: abs_vec_nth_blinfun_apply_lemma) done lemma matrix_has_derivative: shows "((λx::(real^'n)⇒⇩L(real^'n). matrix (blinfun_apply x)) has_derivative (λh. matrix (blinfun_apply h))) (at x)" apply (auto simp: has_derivative_at2) unfolding linear_linear subgoal by (rule bounded_linear_matrix_blinfun_apply) subgoal by (auto simp: blinfun.bilinear_simps matrix_def) vector done lemma matrix_comp_has_derivative[derivative_intros]: fixes f::"'a::real_normed_vector ⇒ ((real^'n)⇒⇩L(real^'n))" assumes "(f has_derivative f') (at x within S)" shows "((λx. matrix (blinfun_apply (f x))) has_derivative (λx. matrix (f' x))) (at x within S)" using has_derivative_compose[OF assms matrix_has_derivative] by auto fun inner_floatariths where "inner_floatariths [] _ = Num 0" | "inner_floatariths _ [] = Num 0" | "inner_floatariths (x#xs) (y#ys) = Add (Mult x y) (inner_floatariths xs ys)" lemma interpret_floatarith_inner_eq: assumes "length xs = length ys" shows "interpret_floatarith (inner_floatariths xs ys) vs = (∑i<length ys. (interpret_floatariths xs vs ! i) * (interpret_floatariths ys vs ! i))" using assms proof (induction rule: list_induct2) case Nil then show ?case by simp next case (Cons x xs y ys) then show ?case unfolding length_Cons sum.lessThan_Suc_shift by simp qed lemma interpret_floatarith_inner_floatariths: assumes "length xs = DIM('a::executable_euclidean_space)" assumes "length ys = DIM('a)" assumes "eucl_of_list (interpret_floatariths xs vs) = (x::'a)" assumes "eucl_of_list (interpret_floatariths ys vs) = y" shows "interpret_floatarith (inner_floatariths xs ys) vs = x ∙ y" using assms by (subst euclidean_inner) (auto simp: interpret_floatarith_inner_eq sum_Basis_sum_nth_Basis_list eucl_of_list_inner index_nth_id intro!: euclidean_eqI[where 'a='a] sum.cong) lemma max_Var_floatarith_inner_floatariths[simp]: assumes "length f = length g" shows "max_Var_floatarith (inner_floatariths f g) = max (max_Var_floatariths f) (max_Var_floatariths g)" using assms by (induction f g rule: list_induct2) auto definition FDERIV_floatarith where "FDERIV_floatarith fa xs d = inner_floatariths (map (λx. fold_const_fa (DERIV_floatarith x fa)) xs) d" ― ‹TODO: specialize to ‹FDERIV_floatarith fa [0..<n] [m..<m + n]› and do the rest with @{term subst_floatarith}? TODO: introduce approximation on type @{typ "real^'i^'j"} and use @{term jacobian}?› lemma interpret_floatariths_map: "interpret_floatariths (map f xs) vs = map (λx. interpret_floatarith (f x) vs) xs" by (induct xs) (auto simp: ) lemma max_Var_floatarith_DERIV_floatarith: "max_Var_floatarith (DERIV_floatarith x fa) ≤ max_Var_floatarith fa" by (induction x fa rule: DERIV_floatarith.induct) (auto) lemma max_Var_floatarith_FDERIV_floatarith: "length xs = length d ⟹ max_Var_floatarith (FDERIV_floatarith fa xs d) ≤ max (max_Var_floatarith fa) (max_Var_floatariths d)" unfolding FDERIV_floatarith_def by (auto simp: max_Var_floatariths_Max intro!: max_Var_floatarith_DERIV_floatarith[THEN order_trans] max_Var_floatarith_fold_const_fa[THEN order_trans]) definition FDERIV_floatariths where "FDERIV_floatariths fas xs d = map (λfa. FDERIV_floatarith fa xs d) fas" lemma max_Var_floatarith_FDERIV_floatariths: "length xs = length d ⟹ max_Var_floatariths (FDERIV_floatariths fa xs d) ≤ max (max_Var_floatariths fa) (max_Var_floatariths d)" by (auto simp: FDERIV_floatariths_def max_Var_floatariths_Max intro!: max_Var_floatarith_FDERIV_floatarith[THEN order_trans]) (auto simp: max_def) lemma length_FDERIV_floatariths[simp]: "length (FDERIV_floatariths fas xs ds) = length fas" by (auto simp: FDERIV_floatariths_def) lemma FDERIV_floatariths_nth[simp]: "i < length fas ⟹ FDERIV_floatariths fas xs ds ! i = FDERIV_floatarith (fas ! i) xs ds" by (auto simp: FDERIV_floatariths_def) definition "FDERIV_n_floatariths fas xs ds n = ((λx. FDERIV_floatariths x xs ds)^^n) fas" lemma FDERIV_n_floatariths_Suc[simp]: "FDERIV_n_floatariths fa xs ds 0 = fa" "FDERIV_n_floatariths fa xs ds (Suc n) = FDERIV_floatariths (FDERIV_n_floatariths fa xs ds n) xs ds" by (auto simp: FDERIV_n_floatariths_def) lemma length_FDERIV_n_floatariths[simp]: "length (FDERIV_n_floatariths fa xs ds n) = length fa" by (induction n) (auto simp: FDERIV_n_floatariths_def) lemma max_Var_floatarith_FDERIV_n_floatariths: "length xs = length d ⟹ max_Var_floatariths (FDERIV_n_floatariths fa xs d n) ≤ max (max_Var_floatariths fa) (max_Var_floatariths d)" by (induction n) (auto intro!: max_Var_floatarith_FDERIV_floatariths[THEN order_trans] simp: FDERIV_n_floatariths_def) lemma interpret_floatarith_FDERIV_floatarith_cong: assumes rq: "⋀i. i < max_Var_floatarith f ⟹ rs ! i = qs ! i" assumes [simp]: "length ds = length xs" "length es = length xs" assumes "interpret_floatariths ds qs = interpret_floatariths es rs" shows "interpret_floatarith (FDERIV_floatarith f xs ds) qs = interpret_floatarith (FDERIV_floatarith f xs es) rs" apply (auto simp: FDERIV_floatarith_def interpret_floatarith_inner_eq) apply (rule sum.cong[OF refl]) subgoal premises prems for i proof - have "interpret_floatarith (DERIV_floatarith (xs ! i) f) qs = interpret_floatarith (DERIV_floatarith (xs ! i) f) rs" apply (rule interpret_floatarith_max_Var_cong) apply (auto simp: intro!: rq) by (metis leD le_trans max_Var_floatarith_DERIV_floatarith nat_less_le) moreover have "interpret_floatarith (ds ! i) qs = interpret_floatarith (es ! i) rs" using assms by (metis ‹i ∈ {..<length xs}› interpret_floatariths_nth lessThan_iff) ultimately show ?thesis by auto qed done theorem matrix_vector_mult_eq_list_of_eucl_nth: "(M::real^'n::enum^'m::enum) *v v = (∑i<CARD('m). (∑j<CARD('n). list_of_eucl M ! (i * CARD('n) + j) * list_of_eucl v ! j) *⇩R Basis_list ! i)" using eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list[of "list_of_eucl M" "list_of_eucl v", where 'n='n and 'm = 'm] by auto definition "mmult_fa l m n AS BS = concat (map (λi. map (λk. inner_floatariths (map (λj. AS ! (i * m + j)) [0..<m]) (map (λj. BS ! (j * n + k)) [0..<m])) [0..<n]) [0..<l])" lemma length_mmult_fa[simp]: "length (mmult_fa l m n AS BS) = l * n" by (auto simp: mmult_fa_def length_concat o_def sum_list_distinct_conv_sum_set) lemma einterpret_mmult_fa: assumes [simp]: "Dn = CARD('n::enum)" "Dm = CARD('m::enum)" "Dl = CARD('l::enum)" "length A = CARD('l)*CARD('m)" "length B = CARD('m)*CARD('n)" shows "einterpret (mmult_fa Dl Dm Dn A B) vs = (einterpret A vs::((real, 'm::enum) vec, 'l) vec) ** (einterpret B vs::((real, 'n::enum) vec, 'm) vec)" apply (vector matrix_matrix_mult_def) apply (auto simp: mmult_fa_def vec_nth_eucl_of_list_eq2 index_Basis_list_axis2 concat_map_map_index length_concat o_def sum_list_distinct_conv_sum_set interpret_floatarith_inner_eq) apply (subst sum_index_enum_eq) apply simp done lemma max_Var_floatariths_mmult_fa: assumes [simp]: "length A = D * E" "length B = E * F" shows "max_Var_floatariths (mmult_fa D E F A B) ≤ max (max_Var_floatariths A) (max_Var_floatariths B)" apply (auto simp: mmult_fa_def concat_map_map_index intro!: max_Var_floatariths_leI) apply (rule max.coboundedI1) apply (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth max.coboundedI2) apply (cases "F = 0") apply simp_all done lemma isDERIV_inner_iff: assumes "length xs = length ys" shows "isDERIV i (inner_floatariths xs ys) vs ⟷ (∀k < length xs. isDERIV i (xs ! k) vs) ∧ (∀k < length ys. isDERIV i (ys ! k) vs)" using assms by (induction xs ys rule: list_induct2) (auto simp: nth_Cons split: nat.splits) lemma isDERIV_Power: "isDERIV x (fa) vs ⟹ isDERIV x (fa ^⇩e n) vs" by (induction n) (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) lemma isDERIV_mmult_fa_nth: assumes "⋀j. j < D * E ⟹ isDERIV i (A ! j) xs" assumes "⋀j. j < E * F ⟹ isDERIV i (B ! j) xs" assumes [simp]: "length A = D * E" "length B = E * F" "j < D * F" shows "isDERIV i (mmult_fa D E F A B ! j) xs" using assms apply (cases "F = 0") apply (auto simp: mmult_fa_def concat_map_map_index isDERIV_inner_iff ac_simps) apply (metis add.commute assms(5) in_square_lemma less_square_imp_div_less mult.commute) done definition "mvmult_fa n m AS B = map (λi. inner_floatariths (map (λj. AS ! (i * m + j)) [0..<m]) (map (λj. B ! j) [0..<m])) [0..<n]" lemma einterpret_mvmult_fa: assumes [simp]: "Dn = CARD('n::enum)" "Dm = CARD('m::enum)" "length A = CARD('n)*CARD('m)" "length B = CARD('m)" shows "einterpret (mvmult_fa Dn Dm A B) vs = (einterpret A vs::((real, 'm::enum) vec, 'n) vec) *v (einterpret B vs::(real, 'm) vec)" apply (vector matrix_vector_mult_def) apply (auto simp: mvmult_fa_def vec_nth_eucl_of_list_eq2 index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_eucl_of_list_eq concat_map_map_index length_concat o_def sum_list_distinct_conv_sum_set interpret_floatarith_inner_eq) apply (subst sum_index_enum_eq) apply simp done lemma max_Var_floatariths_mvult_fa: assumes [simp]: "length A = D * E" "length B = E" shows "max_Var_floatariths (mvmult_fa D E A B) ≤ max (max_Var_floatariths A) (max_Var_floatariths B)" apply (auto simp: mvmult_fa_def concat_map_map_index intro!: max_Var_floatariths_leI) apply (rule max.coboundedI1) by (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth max.coboundedI2) lemma isDERIV_mvmult_fa_nth: assumes "⋀j. j < D * E ⟹ isDERIV i (A ! j) xs" assumes "⋀j. j < E ⟹ isDERIV i (B ! j) xs" assumes [simp]: "length A = D * E" "length B = E" "j < D" shows "isDERIV i (mvmult_fa D E A B ! j) xs" using assms apply (auto simp: mvmult_fa_def concat_map_map_index isDERIV_inner_iff ac_simps) by (metis assms(5) in_square_lemma semiring_normalization_rules(24) semiring_normalization_rules(7)) lemma max_Var_floatariths_mapI: assumes "⋀x. x ∈ set xs ⟹ max_Var_floatarith (f x) ≤ m" shows "max_Var_floatariths (map f xs) ≤ m" using assms by (force intro!: max_Var_floatariths_leI simp: in_set_conv_nth) lemma max_Var_floatariths_list_updateI: assumes "max_Var_floatariths xs ≤ m" assumes "max_Var_floatarith v ≤ m" assumes "i < length xs" shows "max_Var_floatariths (xs[i := v]) ≤ m" using assms apply (auto simp: nth_list_update intro!: max_Var_floatariths_leI ) using max_Var_floatarith_le_max_Var_floatariths_nthI by blast lemma max_Var_floatariths_replicateI: assumes "max_Var_floatarith v ≤ m" shows "max_Var_floatariths (replicate n v) ≤ m" using assms by (auto intro!: max_Var_floatariths_leI ) definition "FDERIV_n_floatarith fa xs ds n = ((λx. FDERIV_floatarith x xs ds)^^n) fa" lemma FDERIV_n_floatariths_nth: "i < length fas ⟹ FDERIV_n_floatariths fas xs ds n ! i = FDERIV_n_floatarith (fas ! i) xs ds n" by (induction n) (auto simp: FDERIV_n_floatarith_def FDERIV_floatariths_nth) lemma einterpret_fold_const_fa[simp]: "(einterpret (map (λi. fold_const_fa (fa i)) xs) vs::'a::executable_euclidean_space) = einterpret (map fa xs) vs" if "length xs = DIM('a)" using that by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) lemma einterpret_plus[simp]: shows "(einterpret (map (λi. fa1 i + fa2 i) [0..<DIM('a)]) vs::'a) = einterpret (map fa1 [0..<DIM('a::executable_euclidean_space)]) vs + einterpret (map fa2 [0..<DIM('a)]) vs" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) lemma einterpret_uminus[simp]: shows "(einterpret (map (λi. - fa1 i) [0..<DIM('a)]) vs::'a::executable_euclidean_space) = - einterpret (map fa1 [0..<DIM('a)]) vs" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) lemma diff_floatarith_conv_add_uminus: "a - b = a + - b" for a b::floatarith by (auto simp: minus_floatarith_def plus_floatarith_def uminus_floatarith_def) lemma einterpret_minus[simp]: shows "(einterpret (map (λi. fa1 i - fa2 i) [0..<DIM('a)]) vs::'a::executable_euclidean_space) = einterpret (map fa1 [0..<DIM('a)]) vs - einterpret (map fa2 [0..<DIM('a)]) vs" by (simp add: diff_floatarith_conv_add_uminus) lemma einterpret_scaleR[simp]: shows "(einterpret (map (λi. fa1 * fa2 i) [0..<DIM('a)]) vs::'a::executable_euclidean_space) = interpret_floatarith (fa1) vs *⇩R einterpret (map fa2 [0..<DIM('a)]) vs" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) lemma einterpret_nth[simp]: assumes [simp]: "length xs = DIM('a)" shows "(einterpret (map ((!) xs) [0..<DIM('a)]) vs::'a::executable_euclidean_space) = einterpret xs vs" by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner) type_synonym 'n rvec = "(real, 'n) vec" lemma length_mvmult_fa[simp]: "length (mvmult_fa D E xs ys) = D" by (auto simp: mvmult_fa_def) lemma interpret_mvmult_nth: assumes "D = CARD('n::enum)" assumes "E = CARD('m::enum)" assumes "length xs = D * E" assumes "length ys = E" assumes "n < CARD('n)" shows "interpret_floatarith (mvmult_fa D E xs ys ! n) vs = ((einterpret xs vs::((real, 'm) vec, 'n) vec) *v einterpret ys vs) ∙ (Basis_list ! n)" proof - have "interpret_floatarith (mvmult_fa D E xs ys ! n) vs = einterpret (mvmult_fa D E xs ys) vs ∙ (Basis_list ! n::'n rvec)" using assms by (auto simp: eucl_of_list_inner) also from einterpret_mvmult_fa[OF assms(1,2), of xs ys vs] have "einterpret (mvmult_fa D E xs ys) vs = (einterpret xs vs::((real, 'm) vec, 'n) vec) *v einterpret ys vs" using assms by simp finally show ?thesis by simp qed lemmas [simp del] = fold_const_fa.simps lemma take_eq_map_nth: "n < length xs ⟹ take n xs = map ((!) xs) [0..<n]" by (induction xs) (auto intro!: nth_equalityI) lemmas [simp del] = upt_rec_numeral lemmas map_nth_eq_take = take_eq_map_nth[symmetric] subsection ‹Definition of Approximating Function using Affine Arithmetic› lemma interpret_Floatreal: "interpret_floatarith (floatarith.Num f) vs = (real_of_float f)" by simp ML ‹ (* Make a congruence rule out of a defining equation for the interpretation th is one defining equation of f, i.e. th is "f (Cp ?t1 ... ?tn) = P(f ?t1, .., f ?tn)" Cp is a constructor pattern and P is a pattern The result is: [|?A1 = f ?t1 ; .. ; ?An= f ?tn |] ==> P (?A1, .., ?An) = f (Cp ?t1 .. ?tn) + the a list of names of the A1 .. An, Those are fresh in the ctxt *) fun mk_congeq ctxt fs th = let val Const (fN, _) = th |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst |> strip_comb |> fst; val ((_, [th']), ctxt') = Variable.import true [th] ctxt; val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of th')); fun add_fterms (t as t1 $ t2) = if exists (fn f => Term.could_unify (t |> strip_comb |> fst, f)) fs then insert (op aconv) t else add_fterms t1 #> add_fterms t2 | add_fterms (t as Abs _) = if exists_Const (fn (c, _) => c = fN) t then K [t] else K [] | add_fterms _ = I; val fterms = add_fterms rhs []; val (xs, ctxt'') = Variable.variant_fixes (replicate (length fterms) "x") ctxt'; val tys = map fastype_of fterms; val vs = map Free (xs ~~ tys); val env = fterms ~~ vs; (*FIXME*) fun replace_fterms (t as t1 $ t2) = (case AList.lookup (op aconv) env t of SOME v => v | NONE => replace_fterms t1 $ replace_fterms t2) | replace_fterms t = (case AList.lookup (op aconv) env t of SOME v => v | NONE => t); fun mk_def (Abs (x, xT, t), v) = HOLogic.mk_Trueprop (HOLogic.all_const xT $ Abs (x, xT, HOLogic.mk_eq (v $ Bound 0, t))) | mk_def (t, v) = HOLogic.mk_Trueprop (HOLogic.mk_eq (v, t)); fun tryext x = (x RS @{lemma "(∀x. f x = g x) ⟹ f = g" by blast} handle THM _ => x); val cong = (Goal.prove ctxt'' [] (map mk_def env) (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, replace_fterms rhs))) (fn {context, prems, ...} => Local_Defs.unfold0_tac context (map tryext prems) THEN resolve_tac ctxt'' [th'] 1)) RS sym; val (cong' :: vars') = Variable.export ctxt'' ctxt (cong :: map (Drule.mk_term o Thm.cterm_of ctxt'') vs); val vs' = map (fst o fst o Term.dest_Var o Thm.term_of o Drule.dest_term) vars'; in (vs', cong') end; fun mk_congs ctxt eqs = let val fs = fold_rev (fn eq => insert (op =) (eq |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst |> strip_comb |> fst)) eqs []; val tys = fold_rev (fn f => fold (insert (op =)) (f |> fastype_of |> binder_types |> tl)) fs []; val (vs, ctxt') = Variable.variant_fixes (replicate (length tys) "vs") ctxt; val subst = the o AList.lookup (op =) (map2 (fn T => fn v => (T, Thm.cterm_of ctxt' (Free (v, T)))) tys vs); fun prep_eq eq = let val (_, _ :: vs) = eq |> Thm.prop_of |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> fst |> strip_comb; val subst = map_filter (fn Var v => SOME (v, subst (#2 v)) | _ => NONE) vs; in Thm.instantiate ([], subst) eq end; val (ps, congs) = map_split (mk_congeq ctxt' fs o prep_eq) eqs; val bds = AList.make (K ([], [])) tys; in (ps ~~ Variable.export ctxt' ctxt congs, bds) end › ML ‹ fun interpret_floatariths_congs ctxt = mk_congs ctxt @{thms interpret_floatarith.simps interpret_floatariths.simps} |> fst |> map snd › ML ‹ fun preproc_form_conv ctxt = Simplifier.rewrite (put_simpset HOL_basic_ss ctxt addsimps (Named_Theorems.get ctxt @{named_theorems approximation_preproc}))› ML ‹fun reify_floatariths_tac ctxt i = CONVERSION (preproc_form_conv ctxt) i THEN REPEAT_ALL_NEW (fn i => resolve_tac ctxt (interpret_floatariths_congs ctxt) i) i› method_setup reify_floatariths = ‹ Scan.succeed (fn ctxt => SIMPLE_METHOD' (reify_floatariths_tac ctxt)) › "reification of floatariths expression" schematic_goal reify_example: "[xs!i * xs!j, xs!i + xs!j powr (sin (xs!0)), xs!k + (2 / 3 * xs!i * xs!j)] = interpret_floatariths ?fas xs" by (reify_floatariths) ML ‹fun interpret_floatariths_step_tac ctxt i = resolve_tac ctxt (interpret_floatariths_congs ctxt) i› method_setup reify_floatariths_step = ‹ Scan.succeed (fn ctxt => SIMPLE_METHOD' (interpret_floatariths_step_tac ctxt)) › "reification of floatariths expression (step)" lemma eucl_of_list_interpret_floatariths_cong: fixes y::"'a::executable_euclidean_space" assumes "⋀b. b ∈ Basis ⟹ interpret_floatarith (fa (index Basis_list b)) vs = y ∙ b" assumes "length xs = DIM('a)" shows "eucl_of_list (interpret_floatariths (map fa [0..<DIM('a)]) vs) = y" apply (rule euclidean_eqI) apply (subst eucl_of_list_inner) by (auto simp: assms) lemma interpret_floatariths_fold_const_fa[simp]: "interpret_floatariths (map fold_const_fa ds) = interpret_floatariths ds" by (auto intro!: nth_equalityI) fun subst_floatarith where "subst_floatarith s (Add a b) = Add (subst_floatarith s a) (subst_floatarith s b)" | "subst_floatarith s (Mult a b) = Mult (subst_floatarith s a) (subst_floatarith s b)" | "subst_floatarith s (Minus a) = Minus (subst_floatarith s a)" | "subst_floatarith s (Inverse a) = Inverse (subst_floatarith s a)" | "subst_floatarith s (Cos a) = Cos (subst_floatarith s a)" | "subst_floatarith s (Arctan a) = Arctan (subst_floatarith s a)" | "subst_floatarith s (Min a b) = Min (subst_floatarith s a) (subst_floatarith s b)" | "subst_floatarith s (Max a b) = Max (subst_floatarith s a) (subst_floatarith s b)" | "subst_floatarith s (Abs a) = Abs (subst_floatarith s a)" | "subst_floatarith s Pi = Pi" | "subst_floatarith s (Sqrt a) = Sqrt (subst_floatarith s a)" | "subst_floatarith s (Exp a) = Exp (subst_floatarith s a)" | "subst_floatarith s (Powr a b) = Powr (subst_floatarith s a) (subst_floatarith s b)" | "subst_floatarith s (Ln a) = Ln (subst_floatarith s a)" | "subst_floatarith s (Power a i) = Power (subst_floatarith s a) i" | "subst_floatarith s (Floor a) = Floor (subst_floatarith s a)" | "subst_floatarith s (Num f) = Num f" | "subst_floatarith s (Var n) = s n" lemma interpret_floatarith_subst_floatarith: assumes "max_Var_floatarith fa ≤ D" shows "interpret_floatarith (subst_floatarith s fa) vs = interpret_floatarith fa (map (λi. interpret_floatarith (s i) vs) [0..<D])" using assms by (induction fa) auto lemma max_Var_floatarith_subst_floatarith_le[THEN order_trans]: assumes "length xs ≥ max_Var_floatarith fa" shows "max_Var_floatarith (subst_floatarith ((!) xs) fa) ≤ max_Var_floatariths xs" using assms by (induction fa) (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth) lemma max_Var_floatariths_subst_floatarith_le[THEN order_trans]: assumes "length xs ≥ max_Var_floatariths fas" shows "max_Var_floatariths (map (subst_floatarith ((!) xs)) fas) ≤ max_Var_floatariths xs" using assms by (induction fas) (auto simp: max_Var_floatarith_subst_floatarith_le) fun continuous_on_floatarith :: "floatarith ⇒ bool" where "continuous_on_floatarith (Add a b) = (continuous_on_floatarith a ∧ continuous_on_floatarith b)" | "continuous_on_floatarith (Mult a b) = (continuous_on_floatarith a ∧ continuous_on_floatarith b)" | "continuous_on_floatarith (Minus a) = continuous_on_floatarith a" | "continuous_on_floatarith (Inverse a) = False" | "continuous_on_floatarith (Cos a) = continuous_on_floatarith a" | "continuous_on_floatarith (Arctan a) = continuous_on_floatarith a" | "continuous_on_floatarith (Min a b) = (continuous_on_floatarith a ∧ continuous_on_floatarith b)" | "continuous_on_floatarith (Max a b) = (continuous_on_floatarith a ∧ continuous_on_floatarith b)" | "continuous_on_floatarith (Abs a) = continuous_on_floatarith a" | "continuous_on_floatarith Pi = True" | "continuous_on_floatarith (Sqrt a) = False" | "continuous_on_floatarith (Exp a) = continuous_on_floatarith a" | "continuous_on_floatarith (Powr a b) = False" | "continuous_on_floatarith (Ln a) = False" | "continuous_on_floatarith (Floor a) = False" | "continuous_on_floatarith (Power a n) = (if n = 0 then True else continuous_on_floatarith a)" | "continuous_on_floatarith (Num f) = True" | "continuous_on_floatarith (Var n) = True" definition "Maxs⇩e xs = fold (λa b. floatarith.Max a b) xs" definition "norm2⇩e n = Maxs⇩e (map (λj. Norm (map (λi. Var (Suc j * n + i)) [0..<n])) [0..<n]) (Num 0)" definition "N⇩r l = Num (float_of l)" lemma interpret_floatarith_Norm: "interpret_floatarith (Norm xs) vs = L2_set (λi. interpret_floatarith (xs ! i) vs) {0..<length xs}" by (auto simp: Norm_def L2_set_def sum_list_sum_nth power2_eq_square) lemma interpret_floatarith_Nr[simp]: "interpret_floatarith (N⇩r U) vs = real_of_float (float_of U)" by (auto simp: N⇩r_def) fun list_updates where "list_updates [] _ xs = xs" | "list_updates _ [] xs = xs" | "list_updates (i#is) (u#us) xs = list_updates is us (xs[i:=u])" lemma list_updates_nth_notmem: assumes "length xs = length ys" assumes "i ∉ set xs" shows "list_updates xs ys vs ! i = vs ! i" using assms by (induction xs ys arbitrary: i vs rule: list_induct2) auto lemma list_updates_nth_less: assumes "length xs = length ys" "distinct xs" assumes "i < length vs" shows "list_updates xs ys vs ! i = (if i ∈ set xs then ys ! (index xs i) else vs ! i)" using assms by (induction xs ys arbitrary: i vs rule: list_induct2) (auto simp: list_updates_nth_notmem) lemma length_list_updates[simp]: "length (list_updates xs ys vs) = length vs" by (induction xs ys vs rule: list_updates.induct) simp_all lemma list_updates_nth_ge[simp]: "x ≥ length vs ⟹ length xs = length ys ⟹ list_updates xs ys vs ! x = vs ! x" apply (induction xs ys vs rule: list_updates.induct) apply (auto simp: nth_list_update) by (metis list_update_beyond nth_list_update_neq) lemma list_updates_nth: assumes [simp]: "length xs = length ys" "distinct xs" shows "list_updates xs ys vs ! i = (if i < length vs ∧ i ∈ set xs then ys ! index xs i else vs ! i)" by (auto simp: list_updates_nth_less list_updates_nth_notmem) lemma list_of_eucl_coord_update: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" assumes [simp]: "distinct xs" assumes [simp]: "i ∈ Basis" assumes [simp]: "⋀n. n ∈ set xs ⟹ n < length vs" shows "list_updates xs (list_of_eucl (x + (p - x ∙ i) *⇩R i::'a)) vs = (list_updates xs (list_of_eucl x) vs)[xs ! index Basis_list i := p]" apply (auto intro!: nth_equalityI simp: list_updates_nth nth_list_update) apply (simp add: algebra_simps inner_Basis index_nth_id) apply (auto simp add: algebra_simps inner_Basis index_nth_id) done definition "eucl_of_env is vs = eucl_of_list (map (nth vs) is)" lemma list_updates_list_of_eucl_of_env[simp]: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs" shows "list_updates xs (list_of_eucl (eucl_of_env xs vs::'a)) vs = vs" by (auto intro!: nth_equalityI simp: list_updates_nth nth_list_update eucl_of_env_def) lemma nth_nth_eucl_of_env_inner: "b ∈ Basis ⟹ length is = DIM('a) ⟹ vs ! (is ! index Basis_list b) = eucl_of_env is vs ∙ b" for b::"'a::executable_euclidean_space" by (auto simp: eucl_of_env_def eucl_of_list_inner) lemma list_updates_idem[simp]: assumes "(⋀i. i ∈ set X0 ⟹ i < length vs)" shows "(list_updates X0 (map ((!) vs) X0) vs) = vs" using assms by (induction X0) auto lemma pairwise_orthogonal_Basis[intro, simp]: "pairwise orthogonal Basis" by (auto simp: pairwise_alt orthogonal_def inner_Basis) primrec freshs_floatarith where "freshs_floatarith (Var y) x ⟷ (y ∉ set x)" | "freshs_floatarith (Num a) x ⟷ True" | "freshs_floatarith Pi x ⟷ True" | "freshs_floatarith (Cos a) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Abs a) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Arctan a) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Sqrt a) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Exp a) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Floor a) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Power a n) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Minus a) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Ln a) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Inverse a) x ⟷ freshs_floatarith a x" | "freshs_floatarith (Add a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x" | "freshs_floatarith (Mult a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x" | "freshs_floatarith (floatarith.Max a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x" | "freshs_floatarith (floatarith.Min a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x" | "freshs_floatarith (Powr a b) x ⟷ freshs_floatarith a x ∧ freshs_floatarith b x" lemma freshs_floatarith[simp]: assumes "freshs_floatarith fa ds" "length ds = length xs" shows "interpret_floatarith fa (list_updates ds xs vs) = interpret_floatarith fa vs" using assms by (induction fa) (auto simp: list_updates_nth_notmem) lemma freshs_floatarith_max_Var_floatarithI: assumes "⋀x. x ∈ set xs ⟹ max_Var_floatarith f ≤ x" shows "freshs_floatarith f xs" using assms Suc_n_not_le_n by (induction f; force) definition "freshs_floatariths fas xs = (∀fa∈set fas. freshs_floatarith fa xs)" lemma freshs_floatariths_max_Var_floatarithsI: assumes "⋀x. x ∈ set xs ⟹ max_Var_floatariths f ≤ x" shows "freshs_floatariths f xs" using assms le_trans max_Var_floatarith_le_max_Var_floatariths by (force simp: freshs_floatariths_def intro!: freshs_floatarith_max_Var_floatarithI) lemma freshs_floatariths_freshs_floatarithI: assumes "⋀fa. fa ∈ set fas ⟹ freshs_floatarith fa xs" shows "freshs_floatariths fas xs" by (auto simp: freshs_floatariths_def assms) lemma fresh_floatariths_fresh_floatarithI: assumes "freshs_floatariths fas xs" assumes "fa ∈ set fas" shows "freshs_floatarith fa xs" using assms by (auto simp: freshs_floatariths_def) lemma fresh_floatariths_fresh_floatarith[simp]: "fresh_floatariths (fas) i ⟹ fa ∈ set fas ⟹ fresh_floatarith fa i" by (induction fas) auto lemma interpret_floatariths_fresh_cong: assumes "⋀i. ¬fresh_floatariths f i ⟹ xs ! i = ys ! i" shows "interpret_floatariths f ys = interpret_floatariths f xs" by (auto intro!: nth_equalityI assms interpret_floatarith_fresh_cong simp: ) fun subterms :: "floatarith ⇒ floatarith set" where "subterms (Add a b) = insert (Add a b) (subterms a ∪ subterms b)" | "subterms (Mult a b) = insert (Mult a b) (subterms a ∪ subterms b)" | "subterms (Min a b) = insert (Min a b) (subterms a ∪ subterms b)" | "subterms (floatarith.Max a b) = insert (floatarith.Max a b) (subterms a ∪ subterms b)" | "subterms (Powr a b) = insert (Powr a b) (subterms a ∪ subterms b)" | "subterms (Inverse a) = insert (Inverse a) (subterms a)" | "subterms (Cos a) = insert (Cos a) (subterms a)" | "subterms (Arctan a) = insert (Arctan a) (subterms a)" | "subterms (Abs a) = insert (Abs a) (subterms a)" | "subterms (Sqrt a) = insert (Sqrt a) (subterms a)" | "subterms (Exp a) = insert (Exp a) (subterms a)" | "subterms (Ln a) = insert (Ln a) (subterms a)" | "subterms (Power a n) = insert (Power a n) (subterms a)" | "subterms (Floor a) = insert (Floor a) (subterms a)" | "subterms (Minus a) = insert (Minus a) (subterms a)" | "subterms Pi = {Pi}" | "subterms (Var v) = {Var v}" | "subterms (Num n) = {Num n}" lemma subterms_self[simp]: "fa2 ∈ subterms fa2" by (induction fa2) auto lemma interpret_floatarith_FDERIV_floatarith_eucl_of_env:― ‹TODO: cleanup, reduce to DERIV?!› assumes iD: "⋀i. i < DIM('a) ⟹ isDERIV (xs ! i) fa vs" assumes ds_fresh: "freshs_floatarith fa ds" assumes [simp]: "length xs = DIM ('a)" "length ds = DIM ('a)" "⋀i. i ∈ set xs ⟹ i < length vs" "distinct xs" "⋀i. i ∈ set ds ⟹ i < length vs" "distinct ds" shows "((λx::'a::executable_euclidean_space. (interpret_floatarith fa (list_updates xs (list_of_eucl x) vs))) has_derivative (λd. interpret_floatarith (FDERIV_floatarith fa xs (map Var ds)) (list_updates ds (list_of_eucl d) vs) ) ) (at (eucl_of_env xs vs))" using iD ds_fresh proof (induction fa) case (Add fa1 fa2) then show ?case by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric]) next case (Minus fa) then show ?case by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric]) next case (Mult fa1 fa2) then show ?case by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric]) next case (Inverse fa) then show ?case by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] power2_eq_square) next case (Cos fa) then show ?case by (auto intro!: derivative_eq_intros ext simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map add.commute minus_sin_cos_eq simp flip: mult_minus_left list_of_eucl_coord_update cos_pi_minus) next case (Arctan fa) then show ?case by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric]) next case (Abs fa) then show ?case by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] ) next case (Max fa1 fa2) then show ?case by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] ) next case (Min fa1 fa2) then show ?case by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] ) next case Pi then show ?case by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] ) next case (Sqrt fa) then show ?case by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] ) next case (Exp fa) then show ?case by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] ) next case (Powr fa1 fa2) then show ?case by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps divide_simps list_of_eucl_coord_update[symmetric] ) next case (Ln fa) then show ?case by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] ) next case (Power fa x2a) then show ?case apply (cases x2a) apply (auto intro!: DIM_positive derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric]) apply (auto intro!: ext simp: ) by (simp add: semiring_normalization_rules(27)) next case (Floor fa) then show ?case by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] ) next case (Var x) then show ?case apply (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] if_distrib) apply (subst list_updates_nth) apply (auto intro!: derivative_eq_intros ext split: if_splits cong: if_cong simp: if_distribR eucl_of_list_if) apply (subst inner_commute) apply (rule arg_cong[where f="λb. a ∙ b" for a]) apply (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_list_inner list_updates_nth index_nth_id) done next case (Num x) then show ?case by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] ) qed lemma interpret_floatarith_FDERIV_floatarith_append: assumes iD: "⋀i j. i < DIM('a) ⟹ isDERIV i (fa) (list_of_eucl x @ params)" assumes m: "max_Var_floatarith fa ≤ DIM('a) + length params" shows "((λx::'a::executable_euclidean_space. interpret_floatarith fa (list_of_eucl x @ params)) has_derivative (λd. interpret_floatarith (FDERIV_floatarith fa [0..<DIM('a)] (map Var [length params + DIM('a)..<length params + 2*DIM('a)])) (list_of_eucl x @ params @ list_of_eucl d))) (at x)" proof - have m_nth: "ia < max_Var_floatarith fa ⟹ ia < DIM('a) + length params" for ia using less_le_trans m by blast have "((λxa::'a. interpret_floatarith fa (list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ params @ replicate DIM('a) 0))) has_derivative (λd. interpret_floatarith (FDERIV_floatarith fa [0..<DIM('a)] (map Var [length params + DIM('a)..<length params + 2 * DIM('a)])) (list_updates [length params + DIM('a)..<length params + 2 * DIM('a)] (list_of_eucl d) (list_of_eucl x @ params @ replicate DIM('a) 0)))) (at (eucl_of_env [0..<DIM('a)] (list_of_eucl x @ params @ replicate DIM('a) 0)))" by (rule interpret_floatarith_FDERIV_floatarith_eucl_of_env) (auto intro!: iD freshs_floatarith_max_Var_floatarithI isDERIV_max_Var_floatarithI[OF iD] max_Var_floatarith_le_max_Var_floatariths[THEN order_trans] m[THEN order_trans] simp: nth_append add.commute less_diff_conv2 m_nth) moreover have "interpret_floatarith fa (list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ params @ replicate DIM('a) 0)) = interpret_floatarith fa (list_of_eucl xa @ params)" for xa::'a apply (auto intro!: nth_equalityI interpret_floatarith_max_Var_cong simp: ) apply (auto simp: list_updates_nth nth_append dest: m_nth) done moreover have "(list_updates [length params + DIM('a)..<length params + 2 * DIM('a)] (list_of_eucl d) (list_of_eucl x @ params @ replicate DIM('a) 0)) = (list_of_eucl x @ params @ list_of_eucl d)" for d::'a by (auto simp: intro!: nth_equalityI simp: list_updates_nth nth_append add.commute) moreover have "(eucl_of_env [0..<DIM('a)] (list_of_eucl x @ params @ replicate DIM('a) 0)) = x" by (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_env_def eucl_of_list_inner nth_append) ultimately show ?thesis by simp qed lemma interpret_floatarith_FDERIV_floatarith: assumes iD: "⋀i j. i < DIM('a) ⟹ isDERIV i (fa) (list_of_eucl x)" assumes m: "max_Var_floatarith fa ≤ DIM('a)" shows "((λx::'a::executable_euclidean_space. interpret_floatarith fa (list_of_eucl x)) has_derivative (λd. interpret_floatarith (FDERIV_floatarith fa [0..<DIM('a)] (map Var [DIM('a)..<2*DIM('a)])) (list_of_eucl x @ list_of_eucl d))) (at x)" using interpret_floatarith_FDERIV_floatarith_append[where params=Nil,simplified, OF assms] by simp lemma interpret_floatarith_eventually_isDERIV: assumes iD: "⋀i j. i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)" assumes m: "max_Var_floatarith fa ≤ DIM('a::executable_euclidean_space) + length params" shows "∀i < DIM('a). ∀⇩F (x::'a) in at x. isDERIV i fa (list_of_eucl x @ params)" using iD m proof (induction fa) case (Inverse fa) then have "∀i<DIM('a). ∀⇩F x in at x. isDERIV i fa (list_of_eucl x @ params)" by auto moreover have iD: "i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) ≠ 0" for i using Inverse.prems(1)[OF ] by force+ from Inverse have m: "max_Var_floatarith fa ≤ DIM('a) + length params" by simp from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m] have "isCont (λx. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp then have "∀⇩F x in at x. interpret_floatarith fa (list_of_eucl x @ params) ≠ 0" using iD(2) tendsto_imp_eventually_ne by (auto simp: isCont_def) ultimately show ?case by (auto elim: eventually_elim2) next case (Sqrt fa) then have "∀i<DIM('a). ∀⇩F x in at x. isDERIV i fa (list_of_eucl x @ params)" by auto moreover have iD: "i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) > 0" for i using Sqrt.prems(1)[OF ] by force+ from Sqrt have m: "max_Var_floatarith fa ≤ DIM('a) + length params" by simp from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m] have "isCont (λx. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp then have "∀⇩F x in at x. interpret_floatarith fa (list_of_eucl x @ params) > 0" using iD(2) order_tendstoD by (auto simp: isCont_def) ultimately show ?case by (auto elim: eventually_elim2) next case (Powr fa1 fa2) then have "∀i<DIM('a). ∀⇩F x in at x. isDERIV i fa1 (list_of_eucl x @ params)" "∀i<DIM('a). ∀⇩F x in at x. isDERIV i fa2 (list_of_eucl x @ params)" by auto moreover have iD: "i < DIM('a) ⟹ isDERIV i fa1 (list_of_eucl x @ params)" "interpret_floatarith fa1 (list_of_eucl x @ params) > 0" for i using Powr.prems(1) by force+ from Powr have m: "max_Var_floatarith fa1 ≤ DIM('a) + length params" by simp from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m] have "isCont (λx. interpret_floatarith fa1 (list_of_eucl x @ params)) x" by simp then have "∀⇩F x in at x. interpret_floatarith fa1 (list_of_eucl x @ params) > 0" using iD(2) order_tendstoD by (auto simp: isCont_def) ultimately show ?case apply safe subgoal for i apply (safe dest!: spec[of _ i]) subgoal premises prems using prems(1,3,4) by eventually_elim auto done done next case (Ln fa) then have "∀i<DIM('a). ∀⇩F x in at x. isDERIV i fa (list_of_eucl x @ params)" by auto moreover have iD: "i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) > 0" for i using Ln.prems(1)[OF ] by force+ from Ln have m: "max_Var_floatarith fa ≤ DIM('a) + length params" by simp from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m] have "isCont (λx. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp then have "∀⇩F x in at x. interpret_floatarith fa (list_of_eucl x @ params) > 0" using iD(2) order_tendstoD by (auto simp: isCont_def) ultimately show ?case by (auto elim: eventually_elim2) next case (Power fa m) then show ?case by (cases m) auto next case (Floor fa) then have "∀i<DIM('a). ∀⇩F x in at x. isDERIV i fa (list_of_eucl x @ params)" by auto moreover have iD: "i < DIM('a) ⟹ isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) ∉ ℤ" for i using Floor.prems(1)[OF ] by force+ from Floor have m: "max_Var_floatarith fa ≤ DIM('a) + length params" by simp from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m] have cont: "isCont (λx. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp let ?i = "λx. interpret_floatarith fa (list_of_eucl x @ params)" have "∀⇩F y in at x. ?i y > floor (?i x)" "∀⇩F y in at x. ?i y < ceiling (?i x)" using cont by (auto simp: isCont_def eventually_floor_less eventually_less_ceiling iD(2)) then have "∀⇩F x in at x. ?i x ∉ ℤ" apply eventually_elim apply (auto simp: Ints_def) by linarith ultimately show ?case by (auto elim: eventually_elim2) qed (fastforce intro: DIM_positive elim: eventually_elim2)+ lemma eventually_isFDERIV: assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x@params)" assumes m: "max_Var_floatariths fas ≤ DIM('a::executable_euclidean_space) + length params" shows "∀⇩F (x::'a) in at x. isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x @ params)" by (auto simp: isFDERIV_def all_nat_less_eq eventually_ball_finite_distrib isFDERIV_lengthD[OF iD] intro!: interpret_floatarith_eventually_isDERIV[OF isFDERIV_uptD[OF iD], rule_format] max_Var_floatarith_le_max_Var_floatariths[THEN order_trans] m) lemma isFDERIV_eventually_isFDERIV: assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x@params)" assumes m: "max_Var_floatariths fas ≤ DIM('a::executable_euclidean_space) + length params" shows "∀⇩F (x::'a) in at x. isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x @ params)" by (rule eventually_isFDERIV) (use assms in ‹auto simp: isFDERIV_def›) lemma interpret_floatarith_FDERIV_floatariths_eucl_of_env: assumes iD: "isFDERIV DIM('a) xs fas vs" assumes fresh: "freshs_floatariths (fas) ds" assumes [simp]: "length ds = DIM ('a)" "⋀i. i ∈ set xs ⟹ i < length vs" "distinct xs" "⋀i. i ∈ set ds ⟹ i < length vs" "distinct ds" shows "((λx::'a::executable_euclidean_space. eucl_of_list (interpret_floatariths fas (list_updates xs (list_of_eucl x) vs))::'a) has_derivative (λd. eucl_of_list (interpret_floatariths (FDERIV_floatariths fas xs (map Var ds)) (list_updates ds (list_of_eucl d) vs)))) (at (eucl_of_env xs vs))" by (subst has_derivative_componentwise_within) (auto simp add: eucl_of_list_inner isFDERIV_lengthD[OF iD] intro!: interpret_floatarith_FDERIV_floatarith_eucl_of_env iD[THEN isFDERIV_isDERIV_D] fresh_floatariths_fresh_floatarithI fresh) lemma interpret_floatarith_FDERIV_floatariths_append: assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x @ ramsch)" assumes m: "max_Var_floatariths fas ≤ DIM('a) + length ramsch" assumes [simp]: "length fas = DIM('a)" shows "((λx::'a::executable_euclidean_space. eucl_of_list (interpret_floatariths fas (list_of_eucl x@ramsch))::'a) has_derivative (λd. eucl_of_list (interpret_floatariths (FDERIV_floatariths fas [0..<DIM('a)] (map Var [DIM('a)+length ramsch..<2*DIM('a) + length ramsch])) (list_of_eucl x @ ramsch @ list_of_eucl d)))) (at x)" proof - have m_nth: "ia < max_Var_floatariths fas ⟹ ia < DIM('a) + length ramsch" for ia using m by simp have m_nth': "ia < max_Var_floatarith (fas ! j) ⟹ ia < DIM('a) + length ramsch" if "j < DIM('a)" for j ia using m_nth max_Var_floatariths_lessI that by auto have "((λxa::'a. eucl_of_list (interpret_floatariths fas (list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ ramsch @ replicate DIM('a) 0)))::'a) has_derivative (λd. eucl_of_list (interpret_floatariths (FDERIV_floatariths fas [0..<DIM('a)] (map Var [length ramsch + DIM('a)..<length ramsch + 2 * DIM('a)])) (list_updates [length ramsch + DIM('a)..<length ramsch + 2 * DIM('a)] (list_of_eucl d) (list_of_eucl x @ ramsch @ replicate DIM('a) 0))))) (at (eucl_of_env [0..<DIM('a)] (list_of_eucl x @ ramsch @ replicate DIM('a) 0)))" by (rule interpret_floatarith_FDERIV_floatariths_eucl_of_env[of "[0..<DIM('a)]" fas "list_of_eucl x@ramsch@replicate DIM('a) 0" "[length ramsch+DIM('a)..<length ramsch+2*DIM('a)]"]) (auto intro!: iD[THEN isFDERIV_uptD] freshs_floatarith_max_Var_floatarithI isFDERIV_max_Var_congI[OF iD] max_Var_floatarith_le_max_Var_floatariths[THEN order_trans] m[THEN order_trans] freshs_floatariths_max_Var_floatarithsI simp: nth_append m add.commute less_diff_conv2 m_nth) moreover have "interpret_floatariths fas (list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ ramsch @ replicate DIM('a) 0)) = interpret_floatariths fas (list_of_eucl xa @ ramsch)" for xa::'a apply (auto intro!: nth_equalityI interpret_floatarith_max_Var_cong simp: ) apply (auto simp: list_updates_nth nth_append dest: m_nth') done moreover have "(list_updates [DIM('a) + length ramsch..<length ramsch + 2 * DIM('a)] (list_of_eucl d) (list_of_eucl x @ ramsch @ replicate DIM('a) 0)) = (list_of_eucl x @ ramsch @ list_of_eucl d)" for d::'a by (auto simp: intro!: nth_equalityI simp: list_updates_nth nth_append) moreover have "(eucl_of_env [0..<DIM('a)] (list_of_eucl x @ ramsch @ replicate DIM('a) 0)) = x" by (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_env_def eucl_of_list_inner nth_append) ultimately show ?thesis by (simp add: add.commute) qed lemma interpret_floatarith_FDERIV_floatariths: assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x)" assumes m: "max_Var_floatariths fas ≤ DIM('a)" assumes [simp]: "length fas = DIM('a)" shows "((λx::'a::executable_euclidean_space. eucl_of_list (interpret_floatariths fas (list_of_eucl x))::'a) has_derivative (λd. eucl_of_list (interpret_floatariths (FDERIV_floatariths fas [0..<DIM('a)] (map Var [DIM('a)..<2*DIM('a)])) (list_of_eucl x @ list_of_eucl d)))) (at x)" using interpret_floatarith_FDERIV_floatariths_append[where ramsch=Nil, simplified, OF assms] by simp lemma continuous_on_min[continuous_intros]: fixes f g :: "'a::topological_space ⇒ 'b::linorder_topology" shows "continuous_on A f ⟹ continuous_on A g ⟹ continuous_on A (λx. min (f x) (g x))" by (auto simp: continuous_on_def intro!: tendsto_min) lemmas [continuous_intros] = continuous_on_max lemma continuous_on_if_const[continuous_intros]: "continuous_on s f ⟹ continuous_on s g ⟹ continuous_on s (λx. if p then f x else g x)" by (cases p) auto lemma continuous_on_floatarith: assumes "continuous_on_floatarith fa" "length xs = DIM('a)" "distinct xs" shows "continuous_on UNIV (λx. interpret_floatarith fa (list_updates xs (list_of_eucl (x::'a::executable_euclidean_space)) vs))" using assms by (induction fa) (auto intro!: continuous_intros split: if_splits simp: list_updates_nth list_of_eucl_nth_if) fun open_form :: "form ⇒ bool" where "open_form (Bound x a b f) = False" | "open_form (Assign x a f) = False" | "open_form (Less a b) ⟷ continuous_on_floatarith a ∧ continuous_on_floatarith b" | "open_form (LessEqual a b) = False" | "open_form (AtLeastAtMost x a b) = False" | "open_form (Conj f g) ⟷ open_form f ∧ open_form g" | "open_form (Disj f g) ⟷ open_form f ∧ open_form g" lemma open_form: assumes "open_form f" "length xs = DIM('a::executable_euclidean_space)" "distinct xs" shows "open (Collect (λx::'a. interpret_form f (list_updates xs (list_of_eucl x) vs)))" using assms by (induction f) (auto intro!: open_Collect_less continuous_on_floatarith open_Collect_conj open_Collect_disj) primrec isnFDERIV where "isnFDERIV N fas xs ds vs 0 = True" | "isnFDERIV N fas xs ds vs (Suc n) ⟷ isFDERIV N xs (FDERIV_n_floatariths fas xs (map Var ds) n) vs ∧ isnFDERIV N fas xs ds vs n" lemma one_add_square_eq_0: "1 + (x)⇧2 ≠ (0::real)" by (sos "((R<1 + (([~1] * A=0) + (R<1 * (R<1 * [x]^2)))))") lemma isDERIV_fold_const_fa[intro]: assumes "isDERIV x fa vs" shows "isDERIV x (fold_const_fa fa) vs" using assms apply (induction fa) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits option.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits option.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal for fa n by (cases n) (auto simp: fold_const_fa.simps split: floatarith.splits nat.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) (subst (asm) fold_const_fa[symmetric], force)+ subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits) done lemma isDERIV_fold_const_fa_minus[intro!]: assumes "isDERIV x (fold_const_fa fa) vs" shows "isDERIV x (fold_const_fa (Minus fa)) vs" using assms by (induction fa) (auto simp: fold_const_fa.simps split: floatarith.splits) lemma isDERIV_fold_const_fa_plus[intro!]: assumes "isDERIV x (fold_const_fa fa) vs" assumes "isDERIV x (fold_const_fa fb) vs" shows "isDERIV x (fold_const_fa (Add fa fb)) vs" using assms by (induction fa) (auto simp: fold_const_fa.simps split: floatarith.splits option.splits) lemma isDERIV_fold_const_fa_mult[intro!]: assumes "isDERIV x (fold_const_fa fa) vs" assumes "isDERIV x (fold_const_fa fb) vs" shows "isDERIV x (fold_const_fa (Mult fa fb)) vs" using assms by (induction fa) (auto simp: fold_const_fa.simps split: floatarith.splits option.splits) lemma isDERIV_fold_const_fa_power[intro!]: assumes "isDERIV x (fold_const_fa fa) vs" shows "isDERIV x (fold_const_fa (fa ^⇩e n)) vs" apply (cases n, simp add: fold_const_fa.simps split: floatarith.splits) using assms by (induction fa) (auto simp: fold_const_fa.simps split: floatarith.splits option.splits) lemma isDERIV_fold_const_fa_inverse[intro!]: assumes "isDERIV x (fold_const_fa fa) vs" assumes "interpret_floatarith fa vs ≠ 0" shows "isDERIV x (fold_const_fa (Inverse fa)) vs" using assms by (simp add: fold_const_fa.simps) lemma add_square_ne_zero[simp]: "(y::'a::linordered_idom) > 0 ⟹ y + x⇧2 ≠ 0" by auto (metis less_add_same_cancel2 power2_less_0) lemma isDERIV_FDERIV_floatarith: assumes "isDERIV x fa vs" "⋀i. i < length ds ⟹ isDERIV x (ds ! i) vs" assumes [simp]: "length xs = length ds" shows "isDERIV x (FDERIV_floatarith fa xs ds) vs" using assms apply (induction fa) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal for fa n by (cases n) (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) done lemma isDERIV_FDERIV_floatariths: assumes "isFDERIV N xs fas vs" "isFDERIV N xs ds vs" and [simp]: "length fas = length ds" shows "isFDERIV N xs (FDERIV_floatariths fas xs ds) vs" using assms by (auto simp: isFDERIV_def FDERIV_floatariths_def intro!: isDERIV_FDERIV_floatarith) lemma isFDERIV_imp_isFDERIV_FDERIV_n: assumes "length fas = length ds" shows "isFDERIV N xs fas vs ⟹ isFDERIV N xs ds vs ⟹ isFDERIV N xs (FDERIV_n_floatariths fas xs ds n) vs" using assms by (induction n) (auto intro!: isDERIV_FDERIV_floatariths) lemma isFDERIV_map_Var: assumes [simp]: "length ds = N" "length xs = N" shows "isFDERIV N xs (map Var ds) vs" by (auto simp: isFDERIV_def) theorem isFDERIV_imp_isnFDERIV: assumes "isFDERIV N xs fas vs" and [simp]: "length fas = N" "length xs = N" "length ds = N" shows "isnFDERIV N fas xs ds vs n" using assms by (induction n) (auto intro!: isFDERIV_imp_isFDERIV_FDERIV_n isFDERIV_map_Var) lemma eventually_isnFDERIV: assumes iD: "isnFDERIV DIM('a) fas [0..<DIM('a)] [DIM('a)..<2*DIM('a)] (list_of_eucl x @ list_of_eucl (d::'a)) n" assumes m: "max_Var_floatariths fas ≤ 2 * DIM('a::executable_euclidean_space)" shows "∀⇩F (x::'a) in at x. isnFDERIV DIM('a) fas [0..<DIM('a)] [DIM('a)..<2*DIM('a)] (list_of_eucl x @ list_of_eucl d) n" using iD proof (induction n) case (Suc n) then have 1: "∀⇩F x in at x. isnFDERIV DIM('a) fas [0..<DIM('a)] [DIM('a)..<2 * DIM('a)] (list_of_eucl x @ list_of_eucl d) n" and 2: "isFDERIV DIM('a) [0..<DIM('a)] (FDERIV_n_floatariths fas [0..<DIM('a)] (map Var [DIM('a)..<2 * DIM('a)]) n) (list_of_eucl x @ list_of_eucl d)" by simp_all have "max_Var_floatariths (FDERIV_n_floatariths fas [0..<DIM('a)] (map Var [DIM('a)..<2 * DIM('a)]) n) ≤ DIM('a) + length (list_of_eucl d)" by (auto intro!: max_Var_floatarith_FDERIV_n_floatariths[THEN order_trans] m[THEN order_trans]) from eventually_isFDERIV[OF 2 this] 1 show ?case by eventually_elim simp qed simp lemma isFDERIV_open: assumes "max_Var_floatariths fas ≤ DIM('a)" shows "open {x::'a. isFDERIV DIM('a::executable_euclidean_space) [0..<DIM('a)] fas (list_of_eucl x)}" (is "open (Collect ?s)") proof (safe intro!: topological_space_class.openI) fix x::'a assume x: "?s x" with eventually_isFDERIV[where 'a='a, of fas x Nil] have "∀⇩F x in at x. x ∈ Collect ?s" by (auto simp: assms) then obtain S where "open S" "x ∈ S" "(∀xa∈S. xa ≠ x ⟶ ?s xa)" unfolding eventually_at_topological by auto with x show "∃T. open T ∧ x ∈ T ∧ T ⊆ Collect ?s" by (auto intro!: exI[where x=S]) qed lemma interpret_floatarith_FDERIV_floatarith_eq: assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "length ds = DIM('a)" shows "interpret_floatarith (FDERIV_floatarith fa xs ds) vs = einterpret (map (λx. DERIV_floatarith x fa) xs) vs ∙ (einterpret ds vs::'a)" by (auto simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths) lemma interpret_floatariths_FDERIV_floatariths_cong: assumes [simp]: "length d1s = DIM('a::executable_euclidean_space)" "length d2s = DIM('a)" "length fas1 = length fas2" assumes fresh1: "freshs_floatariths fas1 d1s" assumes fresh2: "freshs_floatariths fas2 d2s" assumes eq1: "⋀i. i < length fas1 ⟹ interpret_floatariths (map (λx. DERIV_floatarith x (fas1 ! i)) [0..<DIM('a)]) xs1 = interpret_floatariths (map (λx. DERIV_floatarith x (fas2 ! i)) [0..<DIM('a)]) xs2" assumes eq2: "⋀i. i < DIM('a) ⟹ xs1 ! (d1s ! i) = xs2 ! (d2s ! i)" shows "interpret_floatariths (FDERIV_floatariths fas1 [0..<DIM('a)] (map floatarith.Var d1s)) xs1 = interpret_floatariths (FDERIV_floatariths fas2 [0..<DIM('a)] (map floatarith.Var d2s)) xs2" proof - note eq1 moreover have "interpret_floatariths (map Var d1s) (xs1) = interpret_floatariths (map Var d2s) (xs2)" by (auto intro!: nth_equalityI eq2) ultimately show ?thesis by (auto intro!: nth_equalityI simp: interpret_floatarith_FDERIV_floatarith_eq) qed lemma subst_floatarith_Var_DERIV_floatarith: assumes "⋀x. x = n ⟷ s x = n" shows "subst_floatarith (λx. Var (s x)) (DERIV_floatarith n fa) = DERIV_floatarith n (subst_floatarith (λx. Var (s x)) fa)" using assms proof (induction fa) case (Power fa n) then show ?case by (cases n) auto qed force+ lemma subst_floatarith_inner_floatariths[simp]: assumes "length fs = length gs" shows "subst_floatarith s (inner_floatariths fs gs) = inner_floatariths (map (subst_floatarith s) fs) (map (subst_floatarith s) gs)" using assms by (induction rule: list_induct2) auto fun_cases subst_floatarith_Num: "subst_floatarith s fa = Num y" and subst_floatarith_Add: "subst_floatarith s fa = Add x y" and subst_floatarith_Minus: "subst_floatarith s fa = Minus y" lemma Num_eq_subst_Var[simp]: "Num x = subst_floatarith (λx. Var (s x)) fa ⟷ fa = Num x" by (cases fa) auto lemma Add_eq_subst_VarE: assumes "Add fa1 fa2 = subst_floatarith (λx. Var (s x)) fa" obtains a1 a2 where "fa = Add a1 a2" "fa1 = subst_floatarith (λx. Var (s x)) a1" "fa2 = subst_floatarith (λx. Var (s x)) a2" using assms by (cases fa) auto lemma subst_floatarith_eq_self[simp]: "subst_floatarith s f = f" if "max_Var_floatarith f = 0" using that by (induction f) auto lemma fold_const_fa_unique: "False" if "(⋀x. f = Num x)" using that[of 0] that[of 1] by auto lemma zero_unique: False if "(⋀x::float. x = 0)" using that[of 0] that[of 1] by auto lemma fold_const_fa_Mult_eq_NumE: assumes "fold_const_fa (Mult a b) = Num x" obtains y z where "fold_const_fa a = Num y" "fold_const_fa b = Num z" "x = y * z" | y where "fold_const_fa a = Num 0" "x = 0" | y where "fold_const_fa b = Num 0" "x = 0" using assms by atomize_elim (auto simp: fold_const_fa.simps split!: option.splits if_splits elim!: dest_Num_fa_Some dest_Num_fa_None) lemma fold_const_fa_Add_eq_NumE: assumes "fold_const_fa (Add a b) = Num x" obtains y z where "fold_const_fa a = Num y" "fold_const_fa b = Num z" "x = y + z" using assms by atomize_elim (auto simp: fold_const_fa.simps split!: option.splits if_splits elim!: dest_Num_fa_Some dest_Num_fa_None) lemma subst_floatarith_Var_fold_const_fa[symmetric]: "fold_const_fa (subst_floatarith (λx. Var (s x)) fa) = subst_floatarith (λx. Var (s x)) (fold_const_fa fa)" proof (induction fa) case (Add fa1 fa2) then show ?case apply (auto simp: fold_const_fa.simps split!: floatarith.splits option.splits if_splits elim!: dest_Num_fa_Some) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) done next case (Mult fa1 fa2) then show ?case apply (auto simp: fold_const_fa.simps split!: floatarith.splits option.splits if_splits elim!: dest_Num_fa_Some) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3)) done next case (Min) then show ?case by (auto simp: fold_const_fa.simps split: floatarith.splits) next case (Max) then show ?case by (auto simp: fold_const_fa.simps split: floatarith.splits) qed (auto simp: fold_const_fa.simps split!: floatarith.splits option.splits if_splits elim!: dest_Num_fa_Some) lemma subst_floatarith_eq_Num[simp]: "(subst_floatarith (λx. Var (s x)) fa = Num x) ⟷ fa = Num x" by (induction fa) (auto simp: ) lemma fold_const_fa_subst_eq_Num0_iff[simp]: "fold_const_fa (subst_floatarith (λx. Var (s x)) fa) = Num x ⟷ fold_const_fa fa = Num x" unfolding subst_floatarith_Var_fold_const_fa[symmetric] by simp lemma subst_floatarith_Var_FDERIV_floatarith: assumes len: "length xs = DIM('a::executable_euclidean_space)" and [simp]: "length ds = DIM('a)" assumes eq: "⋀x y. x ∈ set xs ⟹ (y = x) = (s y = x)" shows "subst_floatarith (λx. Var (s x)) (FDERIV_floatarith fa xs ds) = (FDERIV_floatarith (subst_floatarith (λx. Var (s x)) fa) xs (map (subst_floatarith (λx. Var (s x))) ds))" proof - have [simp]: "⋀x. x ∈ set xs ⟹ subst_floatarith (λx. Var (s x)) (DERIV_floatarith x fa1) = (DERIV_floatarith x (subst_floatarith (λx. Var (s x)) fa1))" for fa1 by (rule subst_floatarith_Var_DERIV_floatarith) (rule eq) have map_eq: "(map (λxa. if xa = s x then Num 1 else Num 0) xs) = (map (λxa. if xa = x then Num 1 else Num 0) xs)" for x apply (subst map_eq_conv) using eq[of x x] eq[of "s x"] by (auto simp: ) show ?thesis using len by (induction fa) (auto simp: FDERIV_floatarith_def o_def if_distrib subst_floatarith_Var_fold_const_fa fold_const_fa.simps(18) map_eq cong: map_cong if_cong) qed lemma subst_floatarith_Var_FDERIV_n_nth: assumes len: "length xs = DIM('a::executable_euclidean_space)" and [simp]: "length ds = DIM('a)" assumes eq: "⋀x y. x ∈ set xs ⟹ (y = x) = (s y = x)" assumes [simp]: "i < length fas" shows "subst_floatarith (λx. Var (s x)) (FDERIV_n_floatariths fas xs ds n ! i) = (FDERIV_n_floatariths (map (subst_floatarith (λx. Var (s x))) fas) xs (map (subst_floatarith (λx. Var (s x))) ds) n ! i)" proof (induction n) case (Suc n) show ?case by (simp add: subst_floatarith_Var_FDERIV_floatarith[OF len _ eq] Suc.IH[symmetric]) qed simp lemma subst_floatarith_Var_max_Var_floatarith: assumes "⋀i. i < max_Var_floatarith fa ⟹ s i = i" shows "subst_floatarith (λi. Var (s i)) fa = fa" using assms by (induction fa) auto lemma interpret_floatarith_subst_floatarith_idem: assumes mv: "max_Var_floatarith fa ≤ length vs" assumes idem: "⋀j. j < max_Var_floatarith fa ⟹ vs ! s j = vs ! j" shows "interpret_floatarith (subst_floatarith (λi. Var (s i)) fa) vs = interpret_floatarith fa vs" using assms by (induction fa) auto lemma isDERIV_subst_Var_floatarith: assumes mv: "max_Var_floatarith fa ≤ length vs" assumes idem: "⋀j. j < max_Var_floatarith fa ⟹ vs ! s j = vs ! j" assumes "⋀j. s j = i ⟷ j = i" shows "isDERIV i (subst_floatarith (λi. Var (s i)) fa) vs = isDERIV i fa vs" using mv idem proof (induction fa) case (Power fa n) then show ?case by (cases n) auto qed (auto simp: interpret_floatarith_subst_floatarith_idem) lemma isFDERIV_subst_Var_floatarith: assumes mv: "max_Var_floatariths fas ≤ length vs" assumes idem: "⋀j. j < max_Var_floatariths fas ⟹ vs ! (s j) = vs ! j" assumes "⋀i j. i ∈ set xs ⟹ s j = i ⟷ j = i" shows "isFDERIV n xs (map (subst_floatarith (λi. Var (s i))) fas) vs = isFDERIV n xs fas vs" proof - have mv: "⋀i. i < length fas ⟹ max_Var_floatarith (fas ! i) ≤ length vs" apply (rule order_trans[OF _ mv]) by (intro max_Var_floatarith_le_max_Var_floatariths_nth) have idem: "⋀i j. i < length fas ⟹ j < max_Var_floatarith (fas ! i) ⟹ vs ! s j = vs ! j" using idem by (auto simp: dest!: max_Var_floatariths_lessI) show ?thesis unfolding isFDERIV_def using mv idem assms(3) by (auto simp: isDERIV_subst_Var_floatarith) qed lemma interpret_floatariths_append[simp]: "interpret_floatariths (xs @ ys) vs = interpret_floatariths xs vs @ interpret_floatariths ys vs" by (induction xs) auto lemma not_fresh_inner_floatariths: assumes "length xs = length ys" shows "¬ fresh_floatarith (inner_floatariths xs ys) i ⟷ ¬fresh_floatariths xs i ∨ ¬fresh_floatariths ys i" using assms by (induction xs ys rule: list_induct2) auto lemma fresh_inner_floatariths: assumes "length xs = length ys" shows "fresh_floatarith (inner_floatariths xs ys) i ⟷ fresh_floatariths xs i ∧ fresh_floatariths ys i" using not_fresh_inner_floatariths assms by auto lemma not_fresh_floatariths_map: " ¬ fresh_floatariths (map f xs) i ⟷ (∃x ∈ set xs. ¬fresh_floatarith (f x) i)" by (induction xs) auto lemma fresh_floatariths_map: " fresh_floatariths (map f xs) i ⟷ (∀x ∈ set xs. fresh_floatarith (f x) i)" by (induction xs) auto lemma fresh_floatarith_fold_const_fa: "fresh_floatarith fa i ⟹ fresh_floatarith (fold_const_fa fa) i" by (induction fa) (auto simp: fold_const_fa.simps split: floatarith.splits option.splits) lemma fresh_floatarith_fold_const_fa_Add[intro!]: assumes "fresh_floatarith (fold_const_fa a) i" "fresh_floatarith (fold_const_fa b) i" shows "fresh_floatarith (fold_const_fa (Add a b)) i" using assms by (auto simp: fold_const_fa.simps split!: floatarith.splits option.splits) lemma fresh_floatarith_fold_const_fa_Mult[intro!]: assumes "fresh_floatarith (fold_const_fa a) i" "fresh_floatarith (fold_const_fa b) i" shows "fresh_floatarith (fold_const_fa (Mult a b)) i" using assms by (auto simp: fold_const_fa.simps split!: floatarith.splits option.splits) lemma fresh_floatarith_fold_const_fa_Minus[intro!]: assumes "fresh_floatarith (fold_const_fa b) i" shows "fresh_floatarith (fold_const_fa (Minus b)) i" using assms by (auto simp: fold_const_fa.simps split!: floatarith.splits) lemma fresh_FDERIV_floatarith: "fresh_floatarith ode_e i ⟹ fresh_floatariths ds i ⟹ length ds = DIM('a) ⟹ fresh_floatarith (FDERIV_floatarith ode_e [0..<DIM('a::executable_euclidean_space)] ds) i" proof (induction ode_e) case (Power ode_e n) then show ?case by (cases n) (auto simp: FDERIV_floatarith_def fresh_inner_floatariths fresh_floatariths_map fresh_floatarith_fold_const_fa) qed (auto simp: FDERIV_floatarith_def fresh_inner_floatariths fresh_floatariths_map fresh_floatarith_fold_const_fa) lemma not_fresh_FDERIV_floatarith: "¬ fresh_floatarith (FDERIV_floatarith ode_e [0..<DIM('a::executable_euclidean_space)] ds) i ⟹ length ds = DIM('a) ⟹ ¬fresh_floatarith ode_e i ∨ ¬fresh_floatariths ds i" using fresh_FDERIV_floatarith by auto lemma not_fresh_FDERIV_floatariths: "¬ fresh_floatariths (FDERIV_floatariths ode_e [0..<DIM('a::executable_euclidean_space)] ds) i ⟹ length ds = DIM('a) ⟹ ¬fresh_floatariths ode_e i ∨ ¬fresh_floatariths ds i" by (induction ode_e) (auto simp: FDERIV_floatariths_def dest!: not_fresh_FDERIV_floatarith) lemma isDERIV_FDERIV_floatarith_linear: fixes x h::"'a::executable_euclidean_space" assumes "⋀k. k < DIM('a) ⟹ isDERIV i (DERIV_floatarith k fa) xs" assumes "max_Var_floatarith fa ≤ DIM('a)" assumes [simp]: "length xs = DIM('a)" "length hs = DIM('a)" shows "isDERIV i (FDERIV_floatarith fa [0..<DIM('a)] (map Var [DIM('a)..<2 * DIM('a)])) (xs @ hs)" using assms apply (auto simp: FDERIV_floatarith_def isDERIV_inner_iff) apply (rule isDERIV_max_Var_floatarithI) apply force apply (auto simp: nth_append) by (metis add_diff_inverse_nat leD max_Var_floatarith_DERIV_floatarith max_Var_floatarith_fold_const_fa trans_le_add1) lemma isFDERIV_FDERIV_floatariths_linear: fixes x h::"'a::executable_euclidean_space" assumes "⋀i j k. i < DIM('a) ⟹ j < DIM('a) ⟹ k < DIM('a) ⟹ isDERIV i (DERIV_floatarith k (fas ! j)) (xs)" assumes [simp]: "length fas = DIM('a::executable_euclidean_space)" assumes [simp]: "length xs = DIM('a)" "length hs = DIM('a)" assumes "max_Var_floatariths fas ≤ DIM('a)" shows "isFDERIV DIM('a) [0..<DIM('a::executable_euclidean_space)] (FDERIV_floatariths fas [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)])) (xs @ hs)" apply (auto simp: isFDERIV_def intro!: isDERIV_FDERIV_floatarith_linear assms) using assms(5) max_Var_floatariths_lessI not_le_imp_less by fastforce definition isFDERIV_approx where "isFDERIV_approx p n xs fas vs = ((∀i<n. ∀j<n. isDERIV_approx p (xs ! i) (fas ! j) vs) ∧ length fas = n ∧ length xs = n)" lemma isFDERIV_approx: "bounded_by vs VS ⟹ isFDERIV_approx prec n xs fas VS ⟹ isFDERIV n xs fas vs" by (auto simp: isFDERIV_approx_def isFDERIV_def intro!: isDERIV_approx) primrec isnFDERIV_approx where "isnFDERIV_approx p N fas xs ds vs 0 = True" | "isnFDERIV_approx p N fas xs ds vs (Suc n) ⟷ isFDERIV_approx p N xs (FDERIV_n_floatariths fas xs (map Var ds) n) vs ∧ isnFDERIV_approx p N fas xs ds vs n" lemma isnFDERIV_approx: "bounded_by vs VS ⟹ isnFDERIV_approx prec N fas xs ds VS n ⟹ isnFDERIV N fas xs ds vs n" by (induction n) (auto intro!: isFDERIV_approx) fun plain_floatarith::"nat ⇒ floatarith ⇒ bool" where "plain_floatarith N (floatarith.Add a b) ⟷ plain_floatarith N a ∧ plain_floatarith N b" | "plain_floatarith N (floatarith.Mult a b) ⟷ plain_floatarith N a ∧ plain_floatarith N b" | "plain_floatarith N (floatarith.Minus a) ⟷ plain_floatarith N a" | "plain_floatarith N (floatarith.Pi) ⟷ True" | "plain_floatarith N (floatarith.Num n) ⟷ True" | "plain_floatarith N (floatarith.Var i) ⟷ i < N" | "plain_floatarith N (floatarith.Max a b) ⟷ plain_floatarith N a ∧ plain_floatarith N b" | "plain_floatarith N (floatarith.Min a b) ⟷ plain_floatarith N a ∧ plain_floatarith N b" | "plain_floatarith N (floatarith.Power a n) ⟷ plain_floatarith N a" | "plain_floatarith N (floatarith.Cos a) ⟷ False" ― ‹TODO: should be plain!› | "plain_floatarith N (floatarith.Arctan a) ⟷ False" ― ‹TODO: should be plain!› | "plain_floatarith N (floatarith.Abs a) ⟷ plain_floatarith N a" | "plain_floatarith N (floatarith.Exp a) ⟷ False" ― ‹TODO: should be plain!› | "plain_floatarith N (floatarith.Sqrt a) ⟷ False" ― ‹TODO: should be plain!› | "plain_floatarith N (floatarith.Floor a) ⟷ plain_floatarith N a" | "plain_floatarith N (floatarith.Powr a b) ⟷ False" | "plain_floatarith N (floatarith.Inverse a) ⟷ False" | "plain_floatarith N (floatarith.Ln a) ⟷ False" lemma plain_floatarith_approx_not_None: assumes "plain_floatarith N fa" "N ≤ length XS" "⋀i. i < N ⟹ XS ! i ≠ None" shows "approx p fa XS ≠ None" using assms by (induction fa) (auto simp: Let_def split_beta' prod_eq_iff approx.simps) definition "Rad_of w = w * (Pi / Num 180)" lemma interpret_Rad_of[simp]: "interpret_floatarith (Rad_of w) xs = rad_of (interpret_floatarith w xs)" by (auto simp: Rad_of_def rad_of_def) definition "Deg_of w = Num 180 * w / Pi" lemma interpret_Deg_of[simp]: "interpret_floatarith (Deg_of w) xs = deg_of (interpret_floatarith w xs)" by (auto simp: Deg_of_def deg_of_def inverse_eq_divide) unbundle no_floatarith_notation end
section ‹Straight Line Programs› theory Straight_Line_Program imports Floatarith_Expression Deriving.Derive "HOL-Library.Monad_Syntax" "HOL-Library.RBT_Mapping" begin unbundle floatarith_notation derive (linorder) compare_order float derive linorder floatarith subsection ‹Definition› type_synonym slp = "floatarith list" primrec interpret_slp::"slp ⇒ real list ⇒ real list" where "interpret_slp [] = (λxs. xs)" | "interpret_slp (ea # eas) = (λxs. interpret_slp eas (interpret_floatarith ea xs#xs))" subsection ‹Reification as straight line program (with common subexpression elimination)› definition "slp_index vs i = (length vs - Suc i)" definition "slp_index_lookup vs M a = slp_index vs (the (Mapping.lookup M a))" definition "slp_of_fa_bin Binop a b M slp M2 slp2 = (case Mapping.lookup M (Binop a b) of Some i ⇒ (Mapping.update (Binop a b) (length slp) M, slp@[Var (slp_index slp i)]) | None ⇒ (Mapping.update (Binop a b) (length slp2) M2, slp2@[Binop (Var (slp_index_lookup slp2 M2 a)) (Var (slp_index_lookup slp2 M2 b))]))" definition "slp_of_fa_un Unop a M slp M1 slp1 = (case Mapping.lookup M (Unop a) of Some i ⇒ (Mapping.update (Unop a) (length slp) M, slp@[Var (slp_index slp i)]) | None ⇒ (Mapping.update (Unop a) (length slp1) M1, slp1@[Unop (Var (slp_index_lookup slp1 M1 a))]))" definition "slp_of_fa_cnst Const Const' M vs = (Mapping.update Const (length vs) M, vs @ [case Mapping.lookup M Const of Some i ⇒ Var (slp_index vs i) | None ⇒ Const'])" fun slp_of_fa :: "floatarith ⇒ (floatarith, nat) mapping ⇒ floatarith list ⇒ ((floatarith, nat) mapping × floatarith list)" where "slp_of_fa (Add a b) M slp = (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in slp_of_fa_bin Add a b M slp M2 slp2)" | "slp_of_fa (Mult a b) M slp = (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in slp_of_fa_bin Mult a b M slp M2 slp2)" | "slp_of_fa (Min a b) M slp = (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in slp_of_fa_bin Min a b M slp M2 slp2)" | "slp_of_fa (Max a b) M slp = (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in slp_of_fa_bin Max a b M slp M2 slp2)" | "slp_of_fa (Powr a b) M slp = (let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in slp_of_fa_bin Powr a b M slp M2 slp2)" | "slp_of_fa (Inverse a) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Inverse a M slp M1 slp1)" | "slp_of_fa (Cos a) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Cos a M slp M1 slp1)" | "slp_of_fa (Arctan a) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Arctan a M slp M1 slp1)" | "slp_of_fa (Abs a) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Abs a M slp M1 slp1)" | "slp_of_fa (Sqrt a) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Sqrt a M slp M1 slp1)" | "slp_of_fa (Exp a) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Exp a M slp M1 slp1)" | "slp_of_fa (Ln a) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Ln a M slp M1 slp1)" | "slp_of_fa (Minus a) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Minus a M slp M1 slp1)" | "slp_of_fa (Floor a) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Floor a M slp M1 slp1)" | "slp_of_fa (Power a n) M slp = (let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un (λa. Power a n) a M slp M1 slp1)" | "slp_of_fa Pi M slp = slp_of_fa_cnst Pi Pi M slp" | "slp_of_fa (Var v) M slp = slp_of_fa_cnst (Var v) (Var (v + length slp)) M slp" | "slp_of_fa (Num n) M slp = slp_of_fa_cnst (Num n) (Num n) M slp" lemma interpret_slp_snoc[simp]: "interpret_slp (slp @ [fa]) xs = interpret_floatarith fa (interpret_slp slp xs)#interpret_slp slp xs" by (induction slp arbitrary: fa xs) auto lemma binop_slp_of_fa_induction_step: assumes Binop_IH1: "⋀M slp M' slp'. slp_of_fa fa1 M slp = (M', slp') ⟹ (⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M) ⟹ (⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp) ⟹ (⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs) ⟹ subterms fa1 ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧ (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧ the (Mapping.lookup M' f) < length slp' ∧ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)" and Binop_IH2: "⋀M slp M' slp'. slp_of_fa fa2 M slp = (M', slp') ⟹ (⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M) ⟹ (⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp) ⟹ (⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs) ⟹ subterms fa2 ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧ (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧ the (Mapping.lookup M' f) < length slp' ∧ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)" and Binop_prems: "(case slp_of_fa fa1 M slp of (M1, slp1) ⇒ case slp_of_fa fa2 M1 slp1 of (x, xa) ⇒ slp_of_fa_bin Binop fa1 fa2 M slp x xa) = (M', slp')" "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M" "⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp" "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs" assumes subterms_Binop[simp]: "⋀a b. subterms (Binop a b) = insert (Binop a b) (subterms a ∪ subterms b)" assumes interpret_Binop[simp]: "⋀a b xs. interpret_floatarith (Binop a b) xs = binop (interpret_floatarith a xs) (interpret_floatarith b xs)" shows "insert (Binop fa1 fa2) (subterms fa1 ∪ subterms fa2) ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧ (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧ the (Mapping.lookup M' f) < length slp' ∧ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)" proof - from Binop_prems obtain M1 slp1 M2 slp2 where *: "slp_of_fa fa1 M slp = (M1, slp1)" "slp_of_fa fa2 M1 slp1 = (M2, slp2)" "slp_of_fa_bin Binop fa1 fa2 M slp M2 slp2 = (M', slp')" by (auto split: prod.splits) from Binop_IH1[OF *(1) Binop_prems(2) Binop_prems(3) Binop_prems(4), simplified] have IH1: "f ∈ subterms fa1 ⟹ f ∈ Mapping.keys M1" "f ∈ Mapping.keys M ⟹ f ∈ Mapping.keys M1" "f ∈ Mapping.keys M1 ⟹ subterms f ⊆ Mapping.keys M1" "f ∈ Mapping.keys M1 ⟹ the (Mapping.lookup M1 f) < length slp1" "f ∈ Mapping.keys M1 ⟹ interpret_slp slp1 xs ! slp_index_lookup slp1 M1 f = interpret_floatarith f xs" for f by (auto simp: subset_iff) from Binop_IH2[OF *(2) IH1(3) IH1(4) IH1(5)] have IH2: "f ∈ subterms fa2 ⟹ f ∈ Mapping.keys M2" "f ∈ Mapping.keys M1 ⟹ f ∈ Mapping.keys M2" "f ∈ Mapping.keys M2 ⟹ subterms f ⊆ Mapping.keys M2" "f ∈ Mapping.keys M2 ⟹ the (Mapping.lookup M2 f) < length slp2" "f ∈ Mapping.keys M2 ⟹ interpret_slp slp2 xs ! slp_index_lookup slp2 M2 f = interpret_floatarith f xs" for f by (auto simp: subset_iff) show ?thesis proof (cases "Mapping.lookup M (Binop fa1 fa2)") case None then have M': "M' = Mapping.update (Binop fa1 fa2) (length slp2) M2" and slp': "slp' = slp2 @ [Binop (Var (slp_index_lookup slp2 M2 fa1)) (Var (slp_index_lookup slp2 M2 fa2))]" using * by (auto simp: slp_of_fa_bin_def) have "Mapping.keys M ⊆ Mapping.keys M'" using IH1 IH2 by (auto simp: M') have "Binop fa1 fa2 ∈ Mapping.keys M'" using M' by auto have M'_0: "Mapping.lookup M' (Binop fa1 fa2) = Some (length slp2)" by (auto simp: M' lookup_update) have fa1: "fa1 ∈ Mapping.keys M2" and fa2: "fa2 ∈ Mapping.keys M2" by (force intro: IH2 IH1)+ have rew: "binop (interpret_slp slp2 xs ! slp_index_lookup slp2 M2 fa1) (interpret_slp slp2 xs ! slp_index_lookup slp2 M2 fa2) = binop (interpret_floatarith fa1 xs) (interpret_floatarith fa2 xs)" by (auto simp: IH2 fa1) show ?thesis apply (auto ) subgoal by fact subgoal unfolding M' apply (simp add: ) apply (rule disjI2) apply (rule IH2(2)) apply (rule IH1) apply simp done subgoal unfolding M' apply (simp add: ) apply (rule disjI2) apply (rule IH2) by simp subgoal unfolding M' apply simp apply (rule disjI2) apply (rule IH2(2)) apply (rule IH1(2)) by simp subgoal unfolding M' apply auto apply (simp add: IH1(1) IH2(2)) apply (simp add: IH1(2) IH2(1)) using IH2(3) by auto subgoal for f unfolding M' slp' apply simp apply (auto simp add: lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def) by (simp add: IH2(4) less_Suc_eq) subgoal for f unfolding M' slp' apply simp apply (subst rew) apply (auto simp add: fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def) apply (auto simp add: nth_Cons fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def split: nat.splits) using IH2(4) apply fastforce by (metis IH2(4) IH2(5) Suc_diff_Suc Suc_inject slp_index_def slp_index_lookup_def) done next case (Some C) then have M': "M' = Mapping.update (Binop fa1 fa2) (length slp) M" and slp': "slp' = slp @ [Var (slp_index slp C)]" and Binop_keys: "(Binop fa1 fa2) ∈ Mapping.keys M" using * by (auto simp: slp_of_fa_bin_def keys_dom_lookup) have "subterms (Binop fa1 fa2) ⊆ Mapping.keys M'" using Binop_keys assms(4) by (force simp: M') moreover have "Mapping.keys M ⊆ Mapping.keys M'" using Binop_keys by (auto simp add: M') moreover have "f∈Mapping.keys M' ⟹ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs" for f apply (auto simp add: M' lookup_map_values lookup_update' slp' Binop_prems slp_index_def slp_index_lookup_def) apply (metis Binop_keys Some assms(6) interpret_Binop option.sel slp_index_def slp_index_lookup_def) apply (metis Binop_keys Some assms(6) interpret_Binop option.sel slp_index_def slp_index_lookup_def) apply (metis assms(6) slp_index_def slp_index_lookup_def) done moreover have "f∈Mapping.keys M' ⟹ subterms f ⊆ Mapping.keys M'" for f using Binop_keys Some assms(4,6) by (auto simp add: M' lookup_map_values) moreover have "f∈Mapping.keys M' ⟹ the (Mapping.lookup M' f) < length slp'" for f using Binop_keys Some assms(5,7) IH1 IH2 by (auto simp add: M' lookup_map_values lookup_update' Binop_prems slp' less_SucI) ultimately show ?thesis by auto qed qed lemma unop_slp_of_fa_induction_step: assumes Unop_IH1: "⋀M slp M' slp'. slp_of_fa fa1 M slp = (M', slp') ⟹ (⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M) ⟹ (⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp) ⟹ (⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs) ⟹ subterms fa1 ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧ (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧ the (Mapping.lookup M' f) < length slp' ∧ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)" and Unop_prems: "(case slp_of_fa fa1 M slp of (M1, slp1) ⇒ slp_of_fa_un Unop fa1 M slp M1 slp1) = (M', slp')" "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M" "⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp" "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs" assumes subterms_Unop[simp]: "⋀a b. subterms (Unop a) = insert (Unop a) (subterms a)" assumes interpret_Unop[simp]: "⋀a b xs. interpret_floatarith (Unop a) xs = unop (interpret_floatarith a xs)" shows "insert (Unop fa1) (subterms fa1) ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧ (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧ the (Mapping.lookup M' f) < length slp' ∧ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)" proof - from Unop_prems obtain M1 slp1 where *: "slp_of_fa fa1 M slp = (M1, slp1)" "slp_of_fa_un Unop fa1 M slp M1 slp1 = (M', slp')" by (auto split: prod.splits) from Unop_IH1[OF *(1) Unop_prems(2) Unop_prems(3) Unop_prems(4), simplified] have IH1: "f ∈ subterms fa1 ⟹ f ∈ Mapping.keys M1" "f ∈ Mapping.keys M ⟹ f ∈ Mapping.keys M1" "f ∈ Mapping.keys M1 ⟹ subterms f ⊆ Mapping.keys M1" "f ∈ Mapping.keys M1 ⟹ the (Mapping.lookup M1 f) < length slp1" "f ∈ Mapping.keys M1 ⟹ interpret_slp slp1 xs ! slp_index_lookup slp1 M1 f = interpret_floatarith f xs" for f by (auto simp: subset_iff) show ?thesis proof (cases "Mapping.lookup M (Unop fa1)") case None then have M': "M' = Mapping.update (Unop fa1) (length slp1) M1 " and slp': "slp' = slp1 @ [Unop (Var (slp_index_lookup slp1 M1 fa1))]" using * by (auto simp: slp_of_fa_un_def) have "Mapping.keys M ⊆ Mapping.keys M'" using IH1 by (auto simp: M') have "Unop fa1 ∈ Mapping.keys M'" using M' by auto have fa1: "fa1 ∈ Mapping.keys M1" by (force intro: IH1)+ have rew: "interpret_slp slp1 xs ! slp_index_lookup slp1 M1 fa1 = interpret_floatarith fa1 xs" by (auto simp: IH1 fa1) show ?thesis apply (auto ) subgoal by fact subgoal unfolding M' apply (simp add: ) apply (rule disjI2) apply (rule IH1) apply simp done subgoal unfolding M' apply (simp add: ) apply (rule disjI2) by (rule IH1) simp subgoal using IH1(3) M' ‹⋀x. x ∈ subterms fa1 ⟹ x ∈ Mapping.keys M'› by fastforce subgoal for f unfolding M' slp' apply simp apply (auto simp add: lookup_update' rew lookup_map_values) by (simp add: IH1(4) less_SucI) subgoal for f unfolding M' slp' apply simp apply (subst rew) apply (auto simp add: fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def) apply (auto simp add: nth_Cons fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def split: nat.splits) using IH1(4) apply fastforce by (metis IH1(4) IH1(5) Suc_diff_Suc Suc_inject slp_index_def slp_index_lookup_def) done next case (Some C) then have M': "M' = Mapping.update (Unop fa1) (length slp) M" and slp': "slp' = slp @ [Var (slp_index slp C)]" and Unop_keys: "(Unop fa1) ∈ Mapping.keys M" using * by (auto simp: slp_of_fa_un_def keys_dom_lookup) have "subterms (Unop fa1) ⊆ Mapping.keys M'" using Unop_keys assms(3) by (force simp: M') moreover have "Mapping.keys M ⊆ Mapping.keys M'" using Unop_keys assms(5) by (force simp: M' IH1) moreover have "f∈Mapping.keys M' ⟹ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs" for f apply (auto simp add: M' lookup_map_values lookup_update' slp' Unop_prems slp_index_def slp_index_lookup_def) apply (metis Unop_keys Some assms(5) interpret_Unop option.sel slp_index_def slp_index_lookup_def) apply (metis Unop_keys Some assms(5) interpret_Unop option.sel slp_index_def slp_index_lookup_def) apply (metis assms(5) slp_index_def slp_index_lookup_def) done moreover have "f∈Mapping.keys M' ⟹ subterms f ⊆ Mapping.keys M'" for f using Unop_keys Some assms(3,5) by (auto simp add: M' lookup_map_values) moreover have "f∈Mapping.keys M' ⟹ the (Mapping.lookup M' f) < length slp'" for f by (auto simp add: M' lookup_map_values lookup_update' slp' Unop_prems IH1 less_SucI) ultimately show ?thesis by auto qed qed lemma cnst_slp_of_fa_induction_step: assumes *: "slp_of_fa_cnst Unop Unop' M slp = (M', slp')" "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M" "⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp" "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs" assumes subterms_Unop[simp]: "⋀a b. subterms (Unop) = {Unop}" assumes interpret_Unop[simp]: "interpret_floatarith Unop xs = unop xs" "interpret_floatarith Unop' (interpret_slp slp xs) = unop xs" assumes ui: "unop (interpret_slp slp xs) = unop xs" shows "{Unop} ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧ (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧ the (Mapping.lookup M' f) < length slp' ∧ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)" proof - show ?thesis proof (cases "Mapping.lookup M Unop") case None then have M': "M' = Mapping.update Unop (length slp) M" and slp': "slp' = slp @ [Unop']" using * by (auto simp: slp_of_fa_cnst_def) have "Mapping.keys M ⊆ Mapping.keys M'" by (auto simp: M') have "Unop ∈ Mapping.keys M'" using M' by auto show ?thesis apply (auto ) subgoal by fact subgoal unfolding M' apply (simp add: ) done subgoal unfolding M' apply (simp add: ) using assms by auto subgoal unfolding M' slp' apply simp apply (auto simp add: lookup_update' ui lookup_map_values) using interpret_Unop apply auto[1] by (simp add: assms(3) less_Suc_eq) subgoal for f unfolding M' slp' apply simp apply (auto simp add: lookup_update' ui lookup_map_values slp_index_lookup_def slp_index_def) using interpret_Unop apply auto[1] apply (auto simp: nth_Cons split: nat.splits) using assms(3) leD apply blast by (metis Suc_diff_Suc Suc_inject assms(3) assms(4) slp_index_def slp_index_lookup_def) done next case (Some C) then have M': "M' = Mapping.update Unop (length slp) M" and slp': "slp' = slp @ [Var (slp_index slp C)]" and Unop_keys: "(Unop) ∈ Mapping.keys M" using * by (auto simp: slp_of_fa_cnst_def keys_dom_lookup) have "subterms (Unop) ⊆ Mapping.keys M'" using Unop_keys by (fastforce simp: M') moreover have "Mapping.keys M ⊆ Mapping.keys M'" using Unop_keys assms(5) by (force simp: M') moreover have "f∈Mapping.keys M' ⟹ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs" for f apply (auto simp add: M' lookup_map_values lookup_update' slp' slp_index_lookup_def slp_index_def) apply (metis Some Unop_keys assms(4) interpret_Unop option.sel slp_index_def slp_index_lookup_def) apply (metis Some Unop_keys assms(4) interpret_Unop option.sel slp_index_def slp_index_lookup_def) by (metis Suc_diff_Suc assms(3) assms(4) nth_Cons_Suc slp_index_def slp_index_lookup_def) moreover have "f∈Mapping.keys M' ⟹ subterms f ⊆ Mapping.keys M'" for f using assms by (auto simp add: M' lookup_map_values lookup_update' slp') moreover have "f∈Mapping.keys M' ⟹ the (Mapping.lookup M' f) < length slp'" for f using assms by (auto simp add: M' lookup_map_values lookup_update' slp' less_SucI) ultimately show ?thesis by auto qed qed lemma interpret_slp_nth: "n ≥ length slp ⟹ interpret_slp slp xs ! n = xs ! (n - length slp)" by (induction slp arbitrary: xs n) auto theorem interpret_slp_of_fa: assumes "slp_of_fa fa M slp = (M', slp')" assumes "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M" assumes "⋀f. f ∈ Mapping.keys M ⟹ (the (Mapping.lookup M f)) < length slp" assumes "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs" shows "subterms fa ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧ (∀f ∈ Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧ the (Mapping.lookup M' f) < length slp' ∧ (interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs))" using assms proof (induction fa arbitrary: M' slp' M slp) case *: (Add fa1 fa2) show ?case unfolding subterms.simps by (rule binop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Mult fa1 fa2) show ?case unfolding subterms.simps by (rule binop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Min fa1 fa2) show ?case unfolding subterms.simps by (rule binop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Max fa1 fa2) show ?case unfolding subterms.simps by (rule binop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Powr fa1 fa2) show ?case unfolding subterms.simps by (rule binop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Minus fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Inverse fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Arctan fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Floor fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Cos fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Ln fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Power fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Abs fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Sqrt fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Exp fa1) show ?case unfolding subterms.simps by (rule unop_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: Pi show ?case unfolding subterms.simps by (rule cnst_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: Num show ?case unfolding subterms.simps by (rule cnst_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto next case *: (Var n) show ?case unfolding subterms.simps by (rule cnst_slp_of_fa_induction_step[OF *[unfolded subterms.simps slp_of_fa.simps Let_def]]) (auto simp: interpret_slp_nth) qed primrec slp_of_fas' where "slp_of_fas' [] M slp = (M, slp)" | "slp_of_fas' (fa#fas) M slp = (let (M, slp) = slp_of_fa fa M slp in slp_of_fas' fas M slp)" theorem interpret_slp_of_fas': assumes "slp_of_fas' fas M slp = (M', slp')" assumes "⋀f. f ∈ Mapping.keys M ⟹ subterms f ⊆ Mapping.keys M" assumes "⋀f. f ∈ Mapping.keys M ⟹ the (Mapping.lookup M f) < length slp" assumes "⋀f. f ∈ Mapping.keys M ⟹ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs" shows "⋃(subterms ` set fas) ⊆ Mapping.keys M' ∧ Mapping.keys M ⊆ Mapping.keys M' ∧ (∀f ∈ Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧ (the (Mapping.lookup M' f) < length slp') ∧ (interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs))" using assms proof (induction fas arbitrary: M slp) case Nil then show ?case by auto next case (Cons fa fas) from ‹slp_of_fas' (fa # fas) M slp = (M', slp')› obtain M1 slp1 where fa: "slp_of_fa fa M slp = (M1, slp1)" and fas: "slp_of_fas' fas M1 slp1 = (M', slp')" by (auto split: prod.splits) have "subterms fa ⊆ Mapping.keys M1 ∧ Mapping.keys M ⊆ Mapping.keys M1 ∧ (∀f∈Mapping.keys M1. subterms f ⊆ Mapping.keys M1 ∧ the (Mapping.lookup M1 f) < length slp1 ∧ interpret_slp slp1 xs ! slp_index_lookup slp1 M1 f= interpret_floatarith f xs)" apply (rule interpret_slp_of_fa[OF fa, of xs]) using Cons.prems by (auto split: prod.splits simp: trans_less_add2) moreover then have "(⋃a∈set fas. subterms a) ⊆ Mapping.keys M' ∧ Mapping.keys M1 ⊆ Mapping.keys M' ∧ (∀f∈Mapping.keys M'. subterms f ⊆ Mapping.keys M' ∧ the (Mapping.lookup M' f) < length slp' ∧ interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)" using Cons.prems by (intro Cons.IH[OF fas]) (auto split: prod.splits simp: trans_less_add2) ultimately show ?case by auto qed definition "slp_of_fas fas = (let (M, slp) = slp_of_fas' fas Mapping.empty []; fasi = map (the o Mapping.lookup M) fas; fasi' = map (λ(a, b). Var (length slp + a - Suc b)) (zip [0..<length fasi] (rev fasi)) in slp @ fasi')" lemma length_interpret_slp[simp]: "length (interpret_slp slp xs) = length slp + length xs" by (induct slp arbitrary: xs) auto lemma length_interpret_floatariths[simp]: "length (interpret_floatariths slp xs) = length slp" by (induct slp arbitrary: xs) auto lemma interpret_slp_append[simp]: "interpret_slp (slp1 @ slp2) xs = interpret_slp slp2 (interpret_slp slp1 xs)" by (induction slp1 arbitrary: slp2 xs) auto lemma "interpret_slp (map Var [a + 0, b + 1, c + 2, d + 3]) xs = (rev (map (λ(i, e). xs ! (e - i)) (zip [0..<4] [a + 0, b + 1, c + 2, d + 3])))@xs" by (auto simp: numeral_eq_Suc) lemma aC_eq_aa: "xs @ y # zs = (xs @ [y]) @ zs" by simp lemma interpret_slp_map_Var: assumes "⋀i. i < length is ⟹ is ! i ≥ i" assumes "⋀i. i < length is ⟹ (is ! i - i) < length xs" shows "interpret_slp (map Var is) xs = (rev (map (λ(i, e). xs ! (e - i)) (zip [0..<length is] is))) @ xs" using assms proof (induction "is" arbitrary: xs) case Nil then show ?case by simp next case (Cons a "is") show ?case unfolding interpret_slp.simps list.map apply (subst Cons.IH) subgoal using Cons.prems by force subgoal using Cons.prems by force subgoal apply (subst aC_eq_aa) apply (subst rev.simps(2)[symmetric]) apply (rule arg_cong[where f="λa. a @ xs"]) apply (rule arg_cong[where f="rev"]) unfolding interpret_floatarith.simps apply auto apply (rule nth_equalityI) apply force apply auto using Cons.prems apply (auto simp: nth_append nth_Cons split: nat.splits) subgoal by (metis Suc_leI le_imp_less_Suc not_le old.nat.simps(5)) subgoal by (simp add: minus_nat.simps(2)) subgoal by (metis Suc_lessI minus_nat.simps(2) old.nat.simps(5)) done done qed theorem slp_of_fas: "take (length fas) (interpret_slp (slp_of_fas fas) xs) = interpret_floatariths fas xs" proof - obtain M slp where Mslp: "slp_of_fas' fas Mapping.empty [] = (M, slp)" using old.prod.exhaust by blast have M: "⋃(subterms ` (set fas)) ⊆ Mapping.keys M ∧ Mapping.keys (Mapping.empty::(floatarith, nat) mapping) ⊆ Mapping.keys M ∧ (∀f∈Mapping.keys M. subterms f ⊆ Mapping.keys M ∧ the (Mapping.lookup M f) < length slp ∧ interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs)" by (rule interpret_slp_of_fas'[OF Mslp]) auto have map_eq: "map (λ(a, b). Var (length slp + a - Suc b)) (zip [0..<length fas] (rev (map ((λx. the o (Mapping.lookup x)) M) fas))) = map Var (map (λ(a, b). (length slp + a - Suc b)) (zip [0..<length fas] (rev (map (the ∘ Mapping.lookup M) fas))))" unfolding split_beta' by (simp add: split_beta') have "take (length fas) (interpret_slp (slp @ map (λ(a, b). Var (length slp + a - Suc b)) (zip [0..<length fas] (rev (map (((λx. the o (Mapping.lookup x))) M) fas)))) xs) = interpret_floatariths fas xs" apply simp unfolding map_eq apply (subst interpret_slp_map_Var) apply (auto simp: rev_nth) subgoal premises prems for i proof - from prems have " (length fas - Suc i) < length fas" using prems by auto then have "fas ! (length fas - Suc i) ∈ set fas" by simp also have "… ⊆ Mapping.keys M" using M by force finally have "fas ! (length fas - Suc i) ∈ Mapping.keys M" . with M show ?thesis by auto qed subgoal premises prems for i proof - from prems have " (length fas - Suc i) < length fas" using prems by auto then have "fas ! (length fas - Suc i) ∈ set fas" by simp also have "… ⊆ Mapping.keys M" using M by force finally have "fas ! (length fas - Suc i) ∈ Mapping.keys M" . with M show ?thesis by auto qed subgoal apply (rule nth_equalityI, auto) subgoal premises prems for i proof - from prems have "fas ! i ∈ set fas" by simp also have "… ⊆ Mapping.keys M" using M by force finally have "fas ! i ∈ Mapping.keys M" . from M[THEN conjunct2, THEN conjunct2, rule_format, OF this] show ?thesis using prems by (auto simp: rev_nth interpret_floatariths_nth slp_index_lookup_def slp_index_def) qed done done then show ?thesis by (auto simp: slp_of_fas_def Let_def Mslp) qed subsection ‹better code equations for construction of large programs› definition "slp_indexl slpl i = slpl - Suc i" definition "slp_indexl_lookup vsl M a = slp_indexl vsl (the (Mapping.lookup M a))" definition "slp_of_fa_rev_bin Binop a b M slp slpl M2 slp2 slpl2 = (case Mapping.lookup M (Binop a b) of Some i ⇒ (Mapping.update (Binop a b) (slpl) M, Var (slp_indexl slpl i)#slp, Suc slpl) | None ⇒ (Mapping.update (Binop a b) (slpl2) M2, Binop (Var (slp_indexl_lookup slpl2 M2 a)) (Var (slp_indexl_lookup slpl2 M2 b))#slp2, Suc slpl2))" definition "slp_of_fa_rev_un Unop a M slp slpl M1 slp1 slpl1 = (case Mapping.lookup M (Unop a) of Some i ⇒ (Mapping.update (Unop a) (slpl) M, Var (slp_indexl slpl i)#slp, Suc slpl) | None ⇒ (Mapping.update (Unop a) (slpl1) M1, Unop (Var (slp_indexl_lookup slpl1 M1 a))#slp1, Suc slpl1))" definition "slp_of_fa_rev_cnst Const Const' M vs vsl = (Mapping.update Const vsl M, (case Mapping.lookup M Const of Some i ⇒ Var (slp_indexl vsl i) | None ⇒ Const')#vs, Suc vsl)" fun slp_of_fa_rev :: "floatarith ⇒ (floatarith, nat) mapping ⇒ floatarith list ⇒ nat ⇒ ((floatarith, nat) mapping × floatarith list × nat)" where "slp_of_fa_rev (Add a b) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in slp_of_fa_rev_bin Add a b M slp slpl M2 slp2 slpl2)" | "slp_of_fa_rev (Mult a b) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in slp_of_fa_rev_bin Mult a b M slp slpl M2 slp2 slpl2)" | "slp_of_fa_rev (Min a b) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in slp_of_fa_rev_bin Min a b M slp slpl M2 slp2 slpl2)" | "slp_of_fa_rev (Max a b) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in slp_of_fa_rev_bin Max a b M slp slpl M2 slp2 slpl2)" | "slp_of_fa_rev (Powr a b) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in slp_of_fa_rev_bin Powr a b M slp slpl M2 slp2 slpl2)" | "slp_of_fa_rev (Inverse a) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Inverse a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev (Cos a) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Cos a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev (Arctan a) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Arctan a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev (Abs a) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Abs a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev (Sqrt a) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Sqrt a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev (Exp a) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Exp a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev (Ln a) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Ln a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev (Minus a) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Minus a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev (Floor a) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Floor a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev (Power a n) M slp slpl = (let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un (λa. Power a n) a M slp slpl M1 slp1 slpl1)" | "slp_of_fa_rev Pi M slp slpl = slp_of_fa_rev_cnst Pi Pi M slp slpl" | "slp_of_fa_rev (Var v) M slp slpl = slp_of_fa_rev_cnst (Var v) (Var (v + slpl)) M slp slpl" | "slp_of_fa_rev (Num n) M slp slpl = slp_of_fa_rev_cnst (Num n) (Num n) M slp slpl" lemma slp_indexl_length[simp]: "slp_indexl (length xs) i = slp_index xs i" by (auto simp: slp_index_def slp_indexl_def) lemma slp_indexl_lookup_length[simp]: "slp_indexl_lookup (length xs) i = slp_index_lookup xs i" by (auto simp: slp_index_lookup_def slp_indexl_lookup_def) lemma slp_index_rev[simp]: "slp_index (rev xs) i = slp_index xs i" by (auto simp: slp_index_def slp_indexl_def) lemma slp_index_lookup_rev[simp]: "slp_index_lookup (rev xs) i = slp_index_lookup xs i" by (auto simp: slp_index_lookup_def slp_indexl_lookup_def) lemma slp_of_fa_bin_slp_of_fa_rev_bin: "slp_of_fa_rev_bin Binop a b M slp (length slp) M2 slp2 (length slp2) = (let (M, slp') = slp_of_fa_bin Binop a b M (rev slp) M2 (rev slp2) in (M, rev slp', length slp'))" by (auto simp: slp_of_fa_rev_bin_def slp_of_fa_bin_def split: prod.splits option.splits) lemma slp_of_fa_un_slp_of_fa_rev_un: "slp_of_fa_rev_un Binop a M slp (length slp) M2 slp2 (length slp2) = (let (M, slp') = slp_of_fa_un Binop a M (rev slp) M2 (rev slp2) in (M, rev slp', length slp'))" by (auto simp: slp_of_fa_rev_un_def slp_of_fa_un_def split: prod.splits option.splits) lemma slp_of_fa_cnst_slp_of_fa_rev_cnst: "slp_of_fa_rev_cnst Cnst Cnst' M slp (length slp) = (let (M, slp') = slp_of_fa_cnst Cnst Cnst' M (rev slp) in (M, rev slp', length slp'))" by (auto simp: slp_of_fa_rev_cnst_def slp_of_fa_cnst_def split: prod.splits option.splits) lemma slp_of_fa_rev: "slp_of_fa_rev fa M slp (length slp) = (let (M, slp') = slp_of_fa fa M (rev slp) in (M, rev slp', length slp'))" proof (induction fa arbitrary: M slp) case (Add fa1 fa2) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin) next case (Minus fa) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Mult fa1 fa2) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin) next case (Inverse fa) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Cos fa) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Arctan fa) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Abs fa) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Max fa1 fa2) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin) next case (Min fa1 fa2) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin) next case Pi then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) next case (Sqrt fa) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Exp fa) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Powr fa1 fa2) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin) next case (Ln fa) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Power fa x2a) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Floor fa) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) (metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un) next case (Var x) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) next case (Num x) then show ?case by (auto split: prod.splits simp: Let_def slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un) qed lemma slp_of_fa_code[code]: "slp_of_fa fa M slp = (let (M, slp', _) = slp_of_fa_rev fa M (rev slp) (length slp) in (M, rev slp'))" using slp_of_fa_rev[of fa M "rev slp"] by (auto split: prod.splits) definition "norm2_slp n = slp_of_fas [floatarith.Inverse (norm2⇩e n)]" unbundle no_floatarith_notation end
section ‹Approximation with Affine Forms› theory Affine_Approximation imports "HOL-Decision_Procs.Approximation" "HOL-Library.Monad_Syntax" "HOL-Library.Mapping" Executable_Euclidean_Space Affine_Form Straight_Line_Program begin text ‹\label{sec:approxaffine}› lemma convex_on_imp_above_tangent:― ‹TODO: generalizes @{thm convex_on_imp_above_tangent}› assumes convex: "convex_on A f" and connected: "connected A" assumes c: "c ∈ A" and x : "x ∈ A" assumes deriv: "(f has_field_derivative f') (at c within A)" shows "f x - f c ≥ f' * (x - c)" proof (cases x c rule: linorder_cases) assume xc: "x > c" let ?A' = "{c<..<x}" have subs: "?A' ⊆ A" using xc x c by (simp add: connected connected_contains_Ioo) have "at c within ?A' ≠ bot" using xc by (simp add: at_within_eq_bot_iff) moreover from deriv have "((λy. (f y - f c) / (y - c)) ⤏ f') (at c within ?A')" unfolding has_field_derivative_iff using subs by (blast intro: tendsto_mono at_le) moreover from eventually_at_right_real[OF xc] have "eventually (λy. (f y - f c) / (y - c) ≤ (f x - f c) / (x - c)) (at_right c)" proof eventually_elim fix y assume y: "y ∈ {c<..<x}" with convex connected x c have "f y ≤ (f x - f c) / (x - c) * (y - c) + f c" using interior_subset[of A] by (intro convex_onD_Icc' convex_on_subset[OF convex] connected_contains_Icc) auto hence "f y - f c ≤ (f x - f c) / (x - c) * (y - c)" by simp thus "(f y - f c) / (y - c) ≤ (f x - f c) / (x - c)" using y xc by (simp add: divide_simps) qed hence "eventually (λy. (f y - f c) / (y - c) ≤ (f x - f c) / (x - c)) (at c within ?A')" by (simp add: eventually_at_filter eventually_mono) ultimately have "f' ≤ (f x - f c) / (x - c)" by (simp add: tendsto_upperbound) thus ?thesis using xc by (simp add: field_simps) next assume xc: "x < c" let ?A' = "{x<..<c}" have subs: "?A' ⊆ A" using xc x c by (simp add: connected connected_contains_Ioo) have "at c within ?A' ≠ bot" using xc by (simp add: at_within_eq_bot_iff) moreover from deriv have "((λy. (f y - f c) / (y - c)) ⤏ f') (at c within ?A')" unfolding has_field_derivative_iff using subs by (blast intro: tendsto_mono at_le) moreover from eventually_at_left_real[OF xc] have "eventually (λy. (f y - f c) / (y - c) ≥ (f x - f c) / (x - c)) (at_left c)" proof eventually_elim fix y assume y: "y ∈ {x<..<c}" with convex connected x c have "f y ≤ (f x - f c) / (c - x) * (c - y) + f c" using interior_subset[of A] by (intro convex_onD_Icc'' convex_on_subset[OF convex] connected_contains_Icc) auto hence "f y - f c ≤ (f x - f c) * ((c - y) / (c - x))" by simp also have "(c - y) / (c - x) = (y - c) / (x - c)" using y xc by (simp add: field_simps) finally show "(f y - f c) / (y - c) ≥ (f x - f c) / (x - c)" using y xc by (simp add: divide_simps) qed hence "eventually (λy. (f y - f c) / (y - c) ≥ (f x - f c) / (x - c)) (at c within ?A')" by (simp add: eventually_at_filter eventually_mono) ultimately have "f' ≥ (f x - f c) / (x - c)" by (simp add: tendsto_lowerbound) thus ?thesis using xc by (simp add: field_simps) qed simp_all text ‹Approximate operations on affine forms.› lemma Affine_notempty[intro, simp]: "Affine X ≠ {}" by (auto simp: Affine_def valuate_def) lemma truncate_up_lt: "x < y ⟹ x < truncate_up prec y" by (rule less_le_trans[OF _ truncate_up]) lemma truncate_up_pos_eq[simp]: "0 < truncate_up p x ⟷ 0 < x" by (auto simp: truncate_up_lt) (metis (poly_guards_query) not_le truncate_up_nonpos) lemma inner_scaleR_pdevs_0: "inner_scaleR_pdevs 0 One_pdevs = zero_pdevs" unfolding inner_scaleR_pdevs_def by transfer (auto simp: unop_pdevs_raw_def) lemma Affine_aform_of_point_eq[simp]: "Affine (aform_of_point p) = {p}" by (simp add: Affine_aform_of_ivl aform_of_point_def) lemma mem_Affine_aform_of_point: "x ∈ Affine (aform_of_point x)" by simp lemma aform_val_aform_of_ivl_innerE: assumes "e ∈ UNIV → {-1 .. 1}" assumes "a ≤ b" "c ∈ Basis" obtains f where "aform_val e (aform_of_ivl a b) ∙ c = aform_val f (aform_of_ivl (a ∙ c) (b ∙ c))" "f ∈ UNIV → {-1 .. 1}" proof - have [simp]: "a ∙ c ≤ b ∙ c" using assms by (auto simp: eucl_le[where 'a='a]) have "(λx. x ∙ c) ` Affine (aform_of_ivl a b) = Affine (aform_of_ivl (a ∙ c) (b ∙ c))" using assms by (auto simp: Affine_aform_of_ivl eucl_le[where 'a='a] image_eqI[where x="∑i∈Basis. (if i = c then x else a ∙ i) *⇩R i" for x]) then obtain f where "aform_val e (aform_of_ivl a b) ∙ c = aform_val f (aform_of_ivl (a ∙ c) (b ∙ c))" "f ∈ UNIV → {-1 .. 1}" using assms by (force simp: Affine_def valuate_def) thus ?thesis .. qed lift_definition coord_pdevs::"nat ⇒ real pdevs" is "λn i. if i = n then 1 else 0" by auto lemma pdevs_apply_coord_pdevs [simp]: "pdevs_apply (coord_pdevs i) x = (if x = i then 1 else 0)" by transfer simp lemma degree_coord_pdevs[simp]: "degree (coord_pdevs i) = Suc i" by (auto intro!: degree_eqI) lemma pdevs_val_coord_pdevs[simp]: "pdevs_val e (coord_pdevs i) = e i" by (auto simp: pdevs_val_sum if_distrib sum.delta cong: if_cong) definition "aforms_of_ivls ls us = map (λ(i, (l, u)). ((l + u)/2, scaleR_pdevs ((u - l)/2) (coord_pdevs i))) (zip [0..<length ls] (zip ls us))" lemma aforms_of_ivls: assumes "length ls = length us" "length xs = length ls" assumes "⋀i. i < length xs ⟹ xs ! i ∈ {ls ! i .. us ! i}" shows "xs ∈ Joints (aforms_of_ivls ls us)" proof - { fix i assume "i < length xs" then have "∃e. e ∈ {-1 .. 1} ∧ xs ! i = (ls ! i + us ! i) / 2 + e * (us ! i - ls ! i) / 2" using assms by (force intro!: exI[where x="(xs ! i - (ls ! i + us ! i) / 2) / (us ! i - ls ! i) * 2"] simp: divide_simps algebra_simps) } then obtain e where e: "e i ∈ {-1 .. 1}" "xs ! i = (ls ! i + us ! i) / 2 + e i * (us ! i - ls ! i) / 2" if "i < length xs" for i using that by metis define e' where "e' i = (if i < length xs then e i else 0)" for i show ?thesis using e assms by (auto simp: aforms_of_ivls_def Joints_def valuate_def e'_def aform_val_def intro!: image_eqI[where x=e'] nth_equalityI) qed subsection ‹Approximate Operations› definition "max_pdev x = fold (λx y. if infnorm (snd x) ≥ infnorm (snd y) then x else y) (list_of_pdevs x) (0, 0)" subsubsection ‹set of generated endpoints› fun points_of_list where "points_of_list x0 [] = [x0]" | "points_of_list x0 ((i, x)#xs) = (points_of_list (x0 + x) xs @ points_of_list (x0 - x) xs)" primrec points_of_aform where "points_of_aform (x, xs) = points_of_list x (list_of_pdevs xs)" subsubsection ‹Approximate total deviation› definition sum_list'::"nat ⇒ 'a list ⇒ 'a::executable_euclidean_space" where "sum_list' p xs = fold (λa b. eucl_truncate_up p (a + b)) xs 0" definition "tdev' p x = sum_list' p (map (abs o snd) (list_of_pdevs x))" lemma eucl_fold_mono: fixes f::"'a::ordered_euclidean_space⇒'a⇒'a" assumes mono: "⋀w x y z. w ≤ x ⟹ y ≤ z ⟹ f w y ≤ f x z" shows "x ≤ y ⟹ fold f xs x ≤ fold f xs y" by (induct xs arbitrary: x y) (auto simp: mono) lemma sum_list_add_le_fold_eucl_truncate_up: fixes z::"'a::executable_euclidean_space" shows "sum_list xs + z ≤ fold (λx y. eucl_truncate_up p (x + y)) xs z" proof (induct xs arbitrary: z) case (Cons x xs) have "sum_list (x # xs) + z = sum_list xs + (z + x)" by simp also have "… ≤ fold (λx y. eucl_truncate_up p (x + y)) xs (z + x)" using Cons by simp also have "… ≤ fold (λx y. eucl_truncate_up p (x + y)) xs (eucl_truncate_up p (x + z))" by (auto intro!: add_mono eucl_fold_mono eucl_truncate_up eucl_truncate_up_mono simp: ac_simps) finally show ?case by simp qed simp lemma sum_list_le_sum_list': "sum_list xs ≤ sum_list' p xs" unfolding sum_list'_def using sum_list_add_le_fold_eucl_truncate_up[of xs 0] by simp lemma sum_list'_sum_list_le: "y ≤ sum_list xs ⟹ y ≤ sum_list' p xs" by (metis sum_list_le_sum_list' order.trans) lemma tdev': "tdev x ≤ tdev' p x" unfolding tdev'_def proof - have "tdev x = (∑i = 0 ..< degree x. ¦pdevs_apply x i¦)" by (auto intro!: sum.mono_neutral_cong_left simp: tdev_def) also have "… = (∑i ← rev [0 ..< degree x]. ¦pdevs_apply x i¦)" by (metis atLeastLessThan_upt sum_list_rev rev_map sum_set_upt_conv_sum_list_nat) also have "… = sum_list (map (λxa. ¦pdevs_apply x xa¦) [xa←rev [0..<degree x] . pdevs_apply x xa ≠ 0])" unfolding filter_map map_map o_def by (subst sum_list_map_filter) auto also note sum_list_le_sum_list'[of _ p] also have "[xa←rev [0..<degree x] . pdevs_apply x xa ≠ 0] = rev (sorted_list_of_set (pdevs_domain x))" by (subst rev_is_rev_conv[symmetric]) (auto simp: filter_map rev_filter intro!: sorted_distinct_set_unique sorted_filter[of "λx. x", simplified] degree_gt) finally show "tdev x ≤ sum_list' p (map (abs ∘ snd) (list_of_pdevs x))" by (auto simp: list_of_pdevs_def o_def rev_map filter_map rev_filter) qed lemma tdev'_le: "x ≤ tdev y ⟹ x ≤ tdev' p y" by (metis order.trans tdev') lemmas abs_pdevs_val_le_tdev' = tdev'_le[OF abs_pdevs_val_le_tdev] lemma tdev'_uminus_pdevs[simp]: "tdev' p (uminus_pdevs x) = tdev' p x" by (auto simp: tdev'_def o_def rev_map filter_map rev_filter list_of_pdevs_def pdevs_domain_def) abbreviation Radius::"'a::ordered_euclidean_space aform ⇒ 'a" where "Radius X ≡ tdev (snd X)" abbreviation Radius'::"nat⇒'a::executable_euclidean_space aform ⇒ 'a" where "Radius' p X ≡ tdev' p (snd X)" lemma Radius'_uminus_aform[simp]: "Radius' p (uminus_aform X) = Radius' p X" by (auto simp: uminus_aform_def) subsubsection ‹truncate partial deviations› definition trunc_pdevs_raw::"nat ⇒ (nat ⇒ 'a) ⇒ nat ⇒ 'a::executable_euclidean_space" where "trunc_pdevs_raw p x i = eucl_truncate_down p (x i)" lemma nonzeros_trunc_pdevs_raw: "{i. trunc_pdevs_raw r x i ≠ 0} ⊆ {i. x i ≠ 0}" by (auto simp: trunc_pdevs_raw_def[abs_def]) lift_definition trunc_pdevs::"nat ⇒ 'a::executable_euclidean_space pdevs ⇒ 'a pdevs" is trunc_pdevs_raw by (auto intro!: finite_subset[OF nonzeros_trunc_pdevs_raw]) definition trunc_err_pdevs_raw::"nat ⇒ (nat ⇒ 'a) ⇒ nat ⇒ 'a::executable_euclidean_space" where "trunc_err_pdevs_raw p x i = trunc_pdevs_raw p x i - x i" lemma nonzeros_trunc_err_pdevs_raw: "{i. trunc_err_pdevs_raw r x i ≠ 0} ⊆ {i. x i ≠ 0}" by (auto simp: trunc_pdevs_raw_def trunc_err_pdevs_raw_def[abs_def]) lift_definition trunc_err_pdevs::"nat ⇒ 'a::executable_euclidean_space pdevs ⇒ 'a pdevs" is trunc_err_pdevs_raw by (auto intro!: finite_subset[OF nonzeros_trunc_err_pdevs_raw]) term float_plus_down lemma pdevs_apply_trunc_pdevs[simp]: fixes x y::"'a::euclidean_space" shows "pdevs_apply (trunc_pdevs p X) n = eucl_truncate_down p (pdevs_apply X n)" by transfer (simp add: trunc_pdevs_raw_def) lemma pdevs_apply_trunc_err_pdevs[simp]: fixes x y::"'a::euclidean_space" shows "pdevs_apply (trunc_err_pdevs p X) n = eucl_truncate_down p (pdevs_apply X n) - (pdevs_apply X n)" by transfer (auto simp: trunc_err_pdevs_raw_def trunc_pdevs_raw_def) lemma pdevs_val_trunc_pdevs: fixes x y::"'a::euclidean_space" shows "pdevs_val e (trunc_pdevs p X) = pdevs_val e X + pdevs_val e (trunc_err_pdevs p X)" proof - have "pdevs_val e X + pdevs_val e (trunc_err_pdevs p X) = pdevs_val e (add_pdevs X (trunc_err_pdevs p X))" by simp also have "… = pdevs_val e (trunc_pdevs p X)" by (auto simp: pdevs_val_def trunc_pdevs_raw_def trunc_err_pdevs_raw_def) finally show ?thesis by simp qed lemma pdevs_val_trunc_err_pdevs: fixes x y::"'a::euclidean_space" shows "pdevs_val e (trunc_err_pdevs p X) = pdevs_val e (trunc_pdevs p X) - pdevs_val e X" by (simp add: pdevs_val_trunc_pdevs) definition truncate_aform::"nat ⇒ 'a aform ⇒ 'a::executable_euclidean_space aform" where "truncate_aform p x = (eucl_truncate_down p (fst x), trunc_pdevs p (snd x))" definition truncate_error_aform::"nat ⇒ 'a aform ⇒ 'a::executable_euclidean_space aform" where "truncate_error_aform p x = (eucl_truncate_down p (fst x) - fst x, trunc_err_pdevs p (snd x))" lemma abs_aform_val_le: assumes "e ∈ UNIV → {- 1..1}" shows "abs (aform_val e X) ≤ eucl_truncate_up p (¦fst X¦ + tdev' p (snd X))" proof - have "abs (aform_val e X) ≤ ¦fst X¦ + ¦pdevs_val e (snd X)¦" by (auto simp: aform_val_def intro!: abs_triangle_ineq) also have "¦pdevs_val e (snd X)¦ ≤ tdev (snd X)" using assms by (rule abs_pdevs_val_le_tdev) also note tdev' also note eucl_truncate_up finally show ?thesis by simp qed subsubsection ‹truncation with error bound› definition "trunc_bound_eucl p s = (let d = eucl_truncate_down p s; ed = abs (d - s) in (d, eucl_truncate_up p ed))" lemma trunc_bound_euclE: obtains err where "¦err¦ ≤ snd (trunc_bound_eucl p x)" "fst (trunc_bound_eucl p x) = x + err" proof atomize_elim have "fst (trunc_bound_eucl p x) = x + (eucl_truncate_down p x - x)" (is "_ = _ + ?err") by (simp_all add: trunc_bound_eucl_def Let_def) moreover have "abs ?err ≤ snd (trunc_bound_eucl p x)" by (simp add: trunc_bound_eucl_def Let_def eucl_truncate_up) ultimately show "∃err. ¦err¦ ≤ snd (trunc_bound_eucl p x) ∧ fst (trunc_bound_eucl p x) = x + err" by auto qed definition "trunc_bound_pdevs p x = (trunc_pdevs p x, tdev' p (trunc_err_pdevs p x))" lemma pdevs_apply_fst_trunc_bound_pdevs[simp]: "pdevs_apply (fst (trunc_bound_pdevs p x)) = pdevs_apply (trunc_pdevs p x)" by (simp add: trunc_bound_pdevs_def) lemma trunc_bound_pdevsE: assumes "e ∈ UNIV → {- 1..1}" obtains err where "¦err¦ ≤ snd (trunc_bound_pdevs p x)" "pdevs_val e (fst ((trunc_bound_pdevs p x))) = pdevs_val e x + err" proof atomize_elim have "pdevs_val e (fst (trunc_bound_pdevs p x)) = pdevs_val e x + pdevs_val e (add_pdevs (trunc_pdevs p x) (uminus_pdevs x))" (is "_ = _ + ?err") by (simp_all add: trunc_bound_pdevs_def Let_def) moreover have "abs ?err ≤ snd (trunc_bound_pdevs p x)" using assms by (auto simp add: pdevs_val_trunc_pdevs trunc_bound_pdevs_def Let_def eucl_truncate_up intro!: order_trans[OF abs_pdevs_val_le_tdev tdev']) ultimately show "∃err. ¦err¦ ≤ snd (trunc_bound_pdevs p x) ∧ pdevs_val e (fst ((trunc_bound_pdevs p x))) = pdevs_val e x + err" by auto qed lemma degree_add_pdevs_le: assumes "degree X ≤ n" assumes "degree Y ≤ n" shows "degree (add_pdevs X Y) ≤ n" using assms by (auto intro!: degree_le) lemma truncate_aform_error_aform_cancel: "aform_val e (truncate_aform p z) = aform_val e z + aform_val e (truncate_error_aform p z) " by (simp add: truncate_aform_def aform_val_def truncate_error_aform_def pdevs_val_trunc_pdevs) lemma error_absE: assumes "abs err ≤ k" obtains e::real where "err = e * k" "e ∈ {-1 .. 1}" using assms by atomize_elim (safe intro!: exI[where x="err / abs k"] divide_atLeastAtMost_1_absI, auto) lemma eucl_truncate_up_nonneg_eq_zero_iff: "x ≥ 0 ⟹ eucl_truncate_up p x = 0 ⟷ x = 0" by (metis (poly_guards_query) eq_iff eucl_truncate_up eucl_truncate_up_zero) lemma aform_val_consume_error: assumes "abs err ≤ abs (pdevs_apply (snd X) n)" shows "aform_val (e(n := 0)) X + err = aform_val (e(n := err/pdevs_apply (snd X) n)) X" using assms by (auto simp add: aform_val_def) lemma aform_val_consume_errorE: fixes X::"real aform" assumes "abs err ≤ abs (pdevs_apply (snd X) n)" obtains err' where "aform_val (e(n := 0)) X + err = aform_val (e(n := err')) X" "err' ∈ {-1 .. 1}" by atomize_elim (rule aform_val_consume_error assms aform_val_consume_error exI conjI divide_atLeastAtMost_1_absI)+ lemma degree_trunc_pdevs_le: assumes "degree X ≤ n" shows "degree (trunc_pdevs p X) ≤ n" using assms by (auto intro!: degree_le) lemma pdevs_val_sum_less_degree: "pdevs_val e X = (∑i<d. e i *⇩R pdevs_apply X i)" if "degree X ≤ d" unfolding pdevs_val_pdevs_domain apply (rule sum.mono_neutral_cong_left) using that by force+ subsubsection ‹general affine operation› definition "affine_binop (X::real aform) Y a b c d k = (a * fst X + b * fst Y + c, pdev_upd (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))) k d)" lemma pdevs_domain_One_pdevs[simp]: "pdevs_domain (One_pdevs::'a::executable_euclidean_space pdevs) = {0..<DIM('a)}" apply (auto simp: length_Basis_list split: if_splits) subgoal for i using nth_Basis_list_in_Basis[of i, where 'a='a] by (auto simp: length_Basis_list) done lemma pdevs_val_One_pdevs: "pdevs_val e (One_pdevs::'a::executable_euclidean_space pdevs) = (∑i<DIM('a). e i *⇩R Basis_list ! i)" by (auto simp: pdevs_val_pdevs_domain length_Basis_list intro!:sum.cong) lemma affine_binop: assumes "degree_aforms [X, Y] ≤ k" shows "aform_val e (affine_binop X Y a b c d k) = a * aform_val e X + b * aform_val e Y + c + e k * d" using assms by (auto simp: aform_val_def affine_binop_def degrees_def pdevs_val_msum_pdevs degree_add_pdevs_le pdevs_val_One_pdevs Basis_list_real_def algebra_simps) definition "affine_binop' p (X::real aform) Y a b c d k = (let ― ‹TODO: more round-off operations here?› (r, e1) = trunc_bound_eucl p (a * fst X + b * fst Y + c); (Z, e2) = trunc_bound_pdevs p (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))) in (r, pdev_upd Z k (sum_list' p [e1, e2, d])) )" lemma sum_list'_noneg_eq_zero_iff: "sum_list' p xs = 0 ⟷ (∀x∈set xs. x = 0)" if "⋀x. x ∈ set xs ⟹ x ≥ 0" proof safe fix x assume x: "sum_list' p xs = 0" "x ∈ set xs" from that have "0 ≤ sum_list xs" by (auto intro!: sum_list_nonneg) with that x have "sum_list xs = 0" by (metis antisym sum_list_le_sum_list') then have "(∑i<length xs. xs ! i) = 0" by (auto simp: sum_list_sum_nth atLeast0LessThan) then show "x = 0" using x(2) that by (subst (asm) sum_nonneg_eq_0_iff) (auto simp: in_set_conv_nth) next show "∀x∈set xs. x = 0 ⟹ sum_list' p xs = 0" by (induction xs) (auto simp: sum_list'_def) qed lemma affine_binop'E: assumes deg: "degree_aforms [X, Y] ≤ k" assumes e: "e ∈ UNIV → {- 1..1}" assumes d: "abs u ≤ d" obtains ek where "a * aform_val e X + b * aform_val e Y + c + u = aform_val (e(k:=ek)) (affine_binop' p X Y a b c d k)" "ek ∈ {-1 .. 1}" proof - have "a * aform_val e X + b * aform_val e Y + c + u = (a * fst X + b * fst Y + c) + pdevs_val e (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))) + u" (is "_ = ?c + pdevs_val _ ?ps + _") by (auto simp: aform_val_def algebra_simps) from trunc_bound_euclE[of p ?c] obtain ec where ec: "abs ec ≤ snd (trunc_bound_eucl p ?c)" "fst (trunc_bound_eucl p ?c) - ec = ?c" by (auto simp: algebra_simps) moreover from trunc_bound_pdevsE[OF e, of p ?ps] obtain eps where eps: "¦eps¦ ≤ snd (trunc_bound_pdevs p ?ps)" "pdevs_val e (fst (trunc_bound_pdevs p ?ps)) - eps = pdevs_val e ?ps" by (auto simp: algebra_simps) moreover define ek where "ek = (u - ec - eps)/ sum_list' p [snd (trunc_bound_eucl p ?c), snd (trunc_bound_pdevs p ?ps), d]" have "degree (fst (trunc_bound_pdevs p ?ps)) ≤ degree_aforms [X, Y]" by (auto simp: trunc_bound_pdevs_def degrees_def intro!: degree_trunc_pdevs_le degree_add_pdevs_le) moreover from this have "pdevs_apply (fst (trunc_bound_pdevs p ?ps)) k = 0" using deg order_trans by blast ultimately have "a * aform_val e X + b * aform_val e Y + c + u = aform_val (e(k:=ek)) (affine_binop' p X Y a b c d k)" apply (auto simp: affine_binop'_def algebra_simps aform_val_def split: prod.splits) subgoal for x y z apply (cases "sum_list' p [x, z, d] = 0") subgoal apply simp apply (subst (asm) sum_list'_noneg_eq_zero_iff) using d deg by auto subgoal apply (simp add: divide_simps algebra_simps ek_def) using ‹pdevs_apply (fst (trunc_bound_pdevs p (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))))) k = 0› by auto done done moreover have "ek ∈ {-1 .. 1}" unfolding ek_def apply (rule divide_atLeastAtMost_1_absI) apply (rule abs_triangle_ineq4[THEN order_trans]) apply (rule order_trans) apply (rule add_right_mono) apply (rule abs_triangle_ineq4) using ec(1) eps(1) by (auto simp: sum_list'_def eucl_truncate_up_real_def add.assoc intro!: order_trans[OF _ abs_ge_self] order_trans[OF _ truncate_up_le] add_mono d ) ultimately show ?thesis .. qed subsubsection ‹Inf/Sup› definition "Inf_aform' p X = eucl_truncate_down p (fst X - tdev' p (snd X))" definition "Sup_aform' p X = eucl_truncate_up p (fst X + tdev' p (snd X))" lemma Inf_aform': shows "Inf_aform' p X ≤ Inf_aform X" unfolding Inf_aform_def Inf_aform'_def by (auto intro!: eucl_truncate_down_le add_left_mono tdev') lemma Sup_aform': shows "Sup_aform X ≤ Sup_aform' p X" unfolding Sup_aform_def Sup_aform'_def by (rule eucl_truncate_up_le add_left_mono tdev')+ lemma Inf_aform_le_Sup_aform[intro]: "Inf_aform X ≤ Sup_aform X" by (simp add: Inf_aform_def Sup_aform_def algebra_simps) lemma Inf_aform'_le_Sup_aform'[intro]: "Inf_aform' p X ≤ Sup_aform' p X" by (metis Inf_aform' Inf_aform_le_Sup_aform Sup_aform' order.trans) definition "ivls_of_aforms prec = map (λa. Interval' (float_of (Inf_aform' prec a)) (float_of(Sup_aform' prec a)))" lemma assumes "⋀i. e'' i ≤ 1" assumes "⋀i. -1 ≤ e'' i" shows Inf_aform'_le: "Inf_aform' p r ≤ aform_val e'' r" and Sup_aform'_le: "aform_val e'' r ≤ Sup_aform' p r" by (auto intro!: order_trans[OF Inf_aform'] order_trans[OF _ Sup_aform'] Inf_aform Sup_aform simp: Affine_def valuate_def intro!: image_eqI[where x=e''] assms) lemma InfSup_aform'_in_float[intro, simp]: "Inf_aform' p X ∈ float" "Sup_aform' p X ∈ float" by (auto simp: Inf_aform'_def eucl_truncate_down_real_def Sup_aform'_def eucl_truncate_up_real_def) theorem ivls_of_aforms: "xs ∈ Joints XS ⟹ bounded_by xs (ivls_of_aforms prec XS)" by (auto simp: bounded_by_def ivls_of_aforms_def Affine_def valuate_def Pi_iff set_of_eq intro!: Inf_aform'_le Sup_aform'_le dest!: nth_in_AffineI split: Interval'_splits) definition "isFDERIV_aform prec N xs fas AS = isFDERIV_approx prec N xs fas (ivls_of_aforms prec AS)" theorem isFDERIV_aform: assumes "isFDERIV_aform prec N xs fas AS" assumes "vs ∈ Joints AS" shows "isFDERIV N xs fas vs" apply (rule isFDERIV_approx) apply (rule ivls_of_aforms) apply (rule assms) apply (rule assms[unfolded isFDERIV_aform_def]) done definition "env_len env l = (∀xs ∈ env. length xs = l)" lemma env_len_takeI: "env_len xs d1 ⟹ d1 ≥ d ⟹ env_len (take d ` xs) d" by (auto simp: env_len_def) subsection ‹Min Range approximation› lemma linear_lower: fixes x::real assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})" assumes "⋀x. x ∈ {a .. b} ⟹ f' x ≤ u" assumes "x ∈ {a .. b}" shows "f b + u * (x - b) ≤ f x" proof - from assms(2-) mvt_very_simple[of x b f "λx. (*) (f' x)", rule_format, OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]] obtain y where "y ∈ {x .. b}" "f b - f x = (b - x) * f' y" by (auto simp: Bex_def ac_simps) moreover hence "f' y ≤ u" using assms by auto ultimately have "f b - f x ≤ (b - x) * u" by (auto intro!: mult_left_mono) thus ?thesis by (simp add: algebra_simps) qed lemma linear_lower2: fixes x::real assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})" assumes "⋀x. x ∈ {a .. b} ⟹ l ≤ f' x" assumes "x ∈ {a .. b}" shows "f x ≥ f a + l * (x - a)" proof - from assms(2-) mvt_very_simple[of a x f "λx. (*) (f' x)", rule_format, OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]] obtain y where "y ∈ {a .. x}" "f x - f a = (x - a) * f' y" by (auto simp: Bex_def ac_simps) moreover hence "l ≤ f' y" using assms by auto ultimately have "(x - a) * l ≤ f x - f a" by (auto intro!: mult_left_mono) thus ?thesis by (simp add: algebra_simps) qed lemma linear_upper: fixes x::real assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})" assumes "⋀x. x ∈ {a .. b} ⟹ f' x ≤ u" assumes "x ∈ {a .. b}" shows "f x ≤ f a + u * (x - a)" proof - from assms(2-) mvt_very_simple[of a x f "λx. (*) (f' x)", rule_format, OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]] obtain y where "y ∈ {a .. x}" "f x - f a = (x - a) * f' y" by (auto simp: Bex_def ac_simps) moreover hence "f' y ≤ u" using assms by auto ultimately have "(x - a) * u ≥ f x - f a" by (auto intro!: mult_left_mono) thus ?thesis by (simp add: algebra_simps) qed lemma linear_upper2: fixes x::real assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})" assumes "⋀x. x ∈ {a .. b} ⟹ l ≤ f' x" assumes "x ∈ {a .. b}" shows "f x ≤ f b + l * (x - b)" proof - from assms(2-) mvt_very_simple[of x b f "λx. (*) (f' x)", rule_format, OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]] obtain y where "y ∈ {x .. b}" "f b - f x = (b - x) * f' y" by (auto simp: Bex_def ac_simps) moreover hence "l ≤ f' y" using assms by auto ultimately have "f b - f x ≥ (b - x) * l" by (auto intro!: mult_left_mono) thus ?thesis by (simp add: algebra_simps) qed lemma linear_enclosure: fixes x::real assumes "⋀x. x ∈ {a .. b} ⟹ (f has_field_derivative f' x) (at x within {a .. b})" assumes "⋀x. x ∈ {a .. b} ⟹ f' x ≤ u" assumes "x ∈ {a .. b}" shows "f x ∈ {f b + u * (x - b) .. f a + u * (x - a)}" using linear_lower[OF assms] linear_upper[OF assms] by auto definition "mid_err ivl = ((lower ivl + upper ivl::float)/2, (upper ivl - lower ivl)/2)" lemma degree_aform_uminus_aform[simp]: "degree_aform (uminus_aform X) = degree_aform X" by (auto simp: uminus_aform_def) subsubsection ‹Addition› definition add_aform::"'a::real_vector aform ⇒ 'a aform ⇒ 'a aform" where "add_aform x y = (fst x + fst y, add_pdevs (snd x) (snd y))" lemma aform_val_add_aform: shows "aform_val e (add_aform X Y) = aform_val e X + aform_val e Y" by (auto simp: add_aform_def aform_val_def) type_synonym aform_err = "real aform × real" definition add_aform'::"nat ⇒ aform_err ⇒ aform_err ⇒ aform_err" where "add_aform' p x y = (let z0 = trunc_bound_eucl p (fst (fst x) + fst (fst y)); z = trunc_bound_pdevs p (add_pdevs (snd (fst x)) (snd (fst y))) in ((fst z0, fst z), (sum_list' p [snd z0, snd z, abs (snd x), abs (snd y)])))" abbreviation degree_aform_err::"aform_err ⇒ nat" where "degree_aform_err X ≡ degree_aform (fst X)" lemma degree_aform_err_add_aform': assumes "degree_aform_err x ≤ n" assumes "degree_aform_err y ≤ n" shows "degree_aform_err (add_aform' p x y) ≤ n" using assms by (auto simp: add_aform'_def Let_def trunc_bound_pdevs_def intro!: degree_pdev_upd_le degree_trunc_pdevs_le degree_add_pdevs_le) definition "aform_err e Xe = {aform_val e (fst Xe) - snd Xe .. aform_val e (fst Xe) + snd Xe::real}" lemma aform_errI: "x ∈ aform_err e Xe" if "abs (x - aform_val e (fst Xe)) ≤ snd Xe" using that by (auto simp: aform_err_def abs_real_def algebra_simps split: if_splits) lemma add_aform': assumes e: "e ∈ UNIV → {- 1..1}" assumes x: "x ∈ aform_err e X" assumes y: "y ∈ aform_err e Y" shows "x + y ∈ aform_err e (add_aform' p X Y)" proof - let ?t1 = "trunc_bound_eucl p (fst (fst X) + fst (fst Y))" from trunc_bound_euclE obtain e1 where abs_e1: "¦e1¦ ≤ snd ?t1" and e1: "fst ?t1 = fst (fst X) + fst (fst Y) + e1" by blast let ?t2 = "trunc_bound_pdevs p (add_pdevs (snd (fst X)) (snd (fst Y)))" from trunc_bound_pdevsE[OF e, of p "add_pdevs (snd (fst X)) (snd (fst Y))"] obtain e2 where abs_e2: "¦e2¦ ≤ snd (?t2)" and e2: "pdevs_val e (fst ?t2) = pdevs_val e (add_pdevs (snd (fst X)) (snd (fst Y))) + e2" by blast have e_le: "¦e1 + e2 + snd X + snd Y¦ ≤ snd (add_aform' p (X) Y)" apply (auto simp: add_aform'_def Let_def ) apply (rule sum_list'_sum_list_le) apply (simp add: add.assoc) by (intro order.trans[OF abs_triangle_ineq] add_mono abs_e1 abs_e2 order_refl) then show ?thesis apply (intro aform_errI) using x y abs_e1 abs_e2 apply (simp add: aform_val_def aform_err_def add_aform_def add_aform'_def Let_def e1 e2 assms) by (auto intro!: order_trans[OF _ sum_list_le_sum_list'] ) qed subsubsection ‹Scaling› definition aform_scaleR::"real aform ⇒ 'a::real_vector ⇒ 'a aform" where "aform_scaleR x y = (fst x *⇩R y, pdevs_scaleR (snd x) y)" lemma aform_val_scaleR_aform[simp]: shows "aform_val e (aform_scaleR X y) = aform_val e X *⇩R y" by (auto simp: aform_scaleR_def aform_val_def scaleR_left_distrib) subsubsection ‹Multiplication› lemma aform_val_mult_exact: "aform_val e x * aform_val e y = fst x * fst y + pdevs_val e (add_pdevs (scaleR_pdevs (fst y) (snd x)) (scaleR_pdevs (fst x) (snd y))) + (∑i<d. e i *⇩R pdevs_apply (snd x) i)*(∑i<d. e i *⇩R pdevs_apply (snd y) i)" if "degree (snd x) ≤ d" "degree (snd y) ≤ d" using that by (auto simp: pdevs_val_sum_less_degree[where d=d] aform_val_def algebra_simps) lemma sum_times_bound:― ‹TODO: this gives better bounds for the remainder of multiplication› "(∑i<d. e i * f i::real) * (∑i<d. e i * g i) = (∑i<d. (e i)⇧2 * (f i * g i)) + (∑(i, j) | i < j ∧ j < d. (e i * e j) * (f j * g i + f i * g j))" for d::nat proof - have "(∑i<d. e i * f i)*(∑i<d. e i * g i) = (∑(i, j)∈{..<d} × {..<d}. e i * f i * (e j * g j))" unfolding sum_product sum.cartesian_product .. also have "… = (∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). i = j}. e i * f i * (e j * g j)) + ((∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). i < j}. e i * f i * (e j * g j)) + (∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). j < i}. e i * f i * (e j * g j)))" (is "_ = ?a + (?b + ?c)") by (subst sum.union_disjoint[symmetric], force, force, force)+ (auto intro!: sum.cong) also have "?c = (∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). i < j}. e i * f j * (e j * g i))" by (rule sum.reindex_cong[of "λ(x, y). (y, x)"]) (auto intro!: inj_onI) also have "?b + … = (∑(i, j)∈{..<d} × {..<d} ∩ {(i, j). i < j}. (e i * e j) * (f j * g i + f i * g j))" by (auto simp: algebra_simps sum.distrib split_beta') also have "… = (∑(i, j) | i < j ∧ j < d. (e i * e j) * (f j * g i + f i * g j))" by (rule sum.cong) auto also have "?a = (∑i<d. (e i)⇧2 * (f i * g i))" by (rule sum.reindex_cong[of "λi. (i, i)"]) (auto simp: power2_eq_square intro!: inj_onI) finally show ?thesis by simp qed definition mult_aform::"aform_err ⇒ aform_err ⇒ aform_err" where "mult_aform x y = ((fst (fst x) * fst (fst y), (add_pdevs (scaleR_pdevs (fst (fst y)) (snd (fst x))) (scaleR_pdevs (fst (fst x)) (snd (fst y))))), (tdev (snd (fst x)) * tdev (snd (fst y)) + abs (snd x) * (abs (fst (fst y)) + Radius (fst y)) + abs (snd y) * (abs (fst (fst x)) + Radius (fst x)) + abs (snd x) * abs (snd y) ))" lemma mult_aformE: fixes X Y::"aform_err" assumes e: "e ∈ UNIV → {- 1..1}" assumes x: "x ∈ aform_err e X" assumes y: "y ∈ aform_err e Y" shows "x * y ∈ aform_err e (mult_aform X Y)" proof - define ex where "ex ≡ x - aform_val e (fst X)" define ey where "ey ≡ y - aform_val e (fst Y)" have [intro, simp]: "¦ex¦ ≤ ¦snd X¦" "¦ey¦ ≤ ¦snd Y¦" using x y by (auto simp: ex_def ey_def aform_err_def) have "x * y = fst (fst X) * fst (fst Y) + fst (fst Y) * pdevs_val e (snd (fst X)) + fst (fst X) * pdevs_val e (snd (fst Y)) + (pdevs_val e (snd (fst X)) * pdevs_val e (snd (fst Y)) + ex * (fst (fst Y) + pdevs_val e (snd (fst Y))) + ey * (fst (fst X) + pdevs_val e (snd (fst X))) + ex * ey)" (is "_ = ?c + ?d + ?e + ?err") by (auto simp: ex_def ey_def algebra_simps aform_val_def) have abs_err: "abs ?err ≤ snd (mult_aform X Y)" by (auto simp: mult_aform_def abs_mult intro!: abs_triangle_ineq[THEN order_trans] add_mono mult_mono abs_pdevs_val_le_tdev e) show ?thesis apply (auto simp: intro!: aform_errI order_trans[OF _ abs_err]) apply (subst mult_aform_def) apply (auto simp: aform_val_def ex_def ey_def algebra_simps) done qed definition mult_aform'::"nat ⇒ aform_err ⇒ aform_err ⇒ aform_err" where "mult_aform' p x y = ( let (fx, sx) = x; (fy, sy) = y; ex = abs sx; ey = abs sy; z0 = trunc_bound_eucl p (fst fx * fst fy); u = trunc_bound_pdevs p (scaleR_pdevs (fst fy) (snd fx)); v = trunc_bound_pdevs p (scaleR_pdevs (fst fx) (snd fy)); w = trunc_bound_pdevs p (add_pdevs (fst u) (fst v)); tx = tdev' p (snd fx); ty = tdev' p (snd fy); l = truncate_up p (tx * ty); ee = truncate_up p (ex * ey); e1 = truncate_up p (ex * truncate_up p (abs (fst fy) + ty)); e2 = truncate_up p (ey * truncate_up p (abs (fst fx) + tx)) in ((fst z0, (fst w)), (sum_list' p [ee, e1, e2, l, snd z0, snd u, snd v, snd w])))" lemma aform_errE: "abs (x - aform_val e (fst X)) ≤ snd X" if "x ∈ aform_err e X" using that by (auto simp: aform_err_def) lemma mult_aform'E: fixes X Y::"aform_err" assumes e: "e ∈ UNIV → {- 1..1}" assumes x: "x ∈ aform_err e X" assumes y: "y ∈ aform_err e Y" shows "x * y ∈ aform_err e (mult_aform' p X Y)" proof - let ?z0 = "trunc_bound_eucl p (fst (fst X) * fst (fst Y))" from trunc_bound_euclE obtain e1 where abs_e1: "¦e1¦ ≤ snd ?z0" and e1: "fst ?z0 = fst (fst X) * fst (fst Y) + e1" by blast let ?u = "trunc_bound_pdevs p (scaleR_pdevs (fst (fst Y)) (snd (fst X)))" from trunc_bound_pdevsE[OF e] obtain e2 where abs_e2: "¦e2¦ ≤ snd (?u)" and e2: "pdevs_val e (fst ?u) = pdevs_val e (scaleR_pdevs (fst (fst Y)) (snd (fst X))) + e2" by blast let ?v = "trunc_bound_pdevs p (scaleR_pdevs (fst (fst X)) (snd (fst Y)))" from trunc_bound_pdevsE[OF e] obtain e3 where abs_e3: "¦e3¦ ≤ snd (?v)" and e3: "pdevs_val e (fst ?v) = pdevs_val e (scaleR_pdevs (fst (fst X)) (snd (fst Y))) + e3" by blast let ?w = "trunc_bound_pdevs p (add_pdevs (fst ?u) (fst ?v))" from trunc_bound_pdevsE[OF e] obtain e4 where abs_e4: "¦e4¦ ≤ snd (?w)" and e4: "pdevs_val e (fst ?w) = pdevs_val e (add_pdevs (fst ?u) (fst ?v)) + e4" by blast let ?tx = "tdev' p (snd (fst X))" and ?ty = "tdev' p (snd (fst Y))" let ?l = "truncate_up p (?tx * ?ty)" let ?ee = "truncate_up p (abs (snd X) * abs (snd Y))" let ?e1 = "truncate_up p (abs (snd X) * truncate_up p (¦fst (fst Y)¦ + ?ty))" let ?e2 = "truncate_up p (abs (snd Y) * truncate_up p (¦fst (fst X)¦ + ?tx))" let ?e0 = "x * y - fst (fst X) * fst (fst Y) - fst (fst X) * pdevs_val e (snd (fst Y)) - fst (fst Y) * pdevs_val e (snd (fst X))" let ?err = "?e0 - (e1 + e2 + e3 + e4)" have "abs ?err ≤ abs ?e0 + abs e1 + abs e2 + abs e3 + abs e4" by arith also have "… ≤ abs ?e0 + snd ?z0 + snd ?u + snd ?v + snd ?w" unfolding abs_mult by (auto intro!: add_mono mult_mono e abs_pdevs_val_le_tdev' abs_ge_zero abs_e1 abs_e2 abs_e3 abs_e4 intro: tdev'_le) also have asdf: "snd (mult_aform X Y) ≤ tdev' p (snd (fst X)) * tdev' p (snd (fst Y)) + ?e1 + ?e2 + ?ee" by (auto simp: mult_aform_def intro!: add_mono mult_mono order_trans[OF _ tdev'] truncate_up_le) have "abs ?e0 ≤ ?ee + ?e1 + ?e2 + tdev' p (snd (fst X)) * tdev' p (snd (fst Y))" using mult_aformE[OF e x y, THEN aform_errE, THEN order_trans, OF asdf] by (simp add: aform_val_def mult_aform_def) arith also have "tdev' p (snd (fst X)) * tdev' p (snd (fst Y)) ≤ ?l" by (auto intro!: truncate_up_le) also have "?ee + ?e1 + ?e2 + ?l + snd ?z0 + snd ?u + snd ?v + snd ?w ≤ sum_list' p [?ee, ?e1, ?e2, ?l, snd ?z0, snd ?u, snd ?v, snd ?w]" by (rule order_trans[OF _ sum_list_le_sum_list']) simp also have "… ≤ (snd (mult_aform' p X Y))" by (auto simp: mult_aform'_def Let_def assms split: prod.splits) finally have err_le: "abs ?err ≤ (snd (mult_aform' p X Y))" by arith show ?thesis apply (rule aform_errI[OF order_trans[OF _ err_le]]) apply (subst mult_aform'_def) using e1 e2 e3 e4 apply (auto simp: aform_val_def Let_def assms split: prod.splits) done qed lemma degree_aform_mult_aform': assumes "degree_aform_err x ≤ n" assumes "degree_aform_err y ≤ n" shows "degree_aform_err (mult_aform' p x y) ≤ n" using assms by (auto simp: mult_aform'_def Let_def trunc_bound_pdevs_def split: prod.splits intro!: degree_pdev_upd_le degree_trunc_pdevs_le degree_add_pdevs_le) lemma fixes x a b::real assumes "a > 0" assumes "x ∈ {a ..b}" assumes "- inverse (b*b) ≤ alpha" shows inverse_linear_lower: "inverse b + alpha * (x - b) ≤ inverse x" (is ?lower) and inverse_linear_upper: "inverse x ≤ inverse a + alpha * (x - a)" (is ?upper) proof - have deriv_inv: "⋀x. x ∈ {a .. b} ⟹ (inverse has_field_derivative - inverse (x*x)) (at x within {a .. b})" using assms by (auto intro!: derivative_eq_intros) show ?lower using assms by (intro linear_lower[OF deriv_inv]) (auto simp: mult_mono intro!: order_trans[OF _ assms(3)]) show ?upper using assms by (intro linear_upper[OF deriv_inv]) (auto simp: mult_mono intro!: order_trans[OF _ assms(3)]) qed subsubsection ‹Inverse› definition inverse_aform'::"nat ⇒ real aform ⇒ real aform × real" where "inverse_aform' p X = ( let l = Inf_aform' p X in let u = Sup_aform' p X in let a = min (abs l) (abs u) in let b = max (abs l) (abs u) in let sq = truncate_up p (b * b) in let alpha = - real_divl p 1 sq in let dmax = truncate_up p (real_divr p 1 a - alpha * a) in let dmin = truncate_down p (real_divl p 1 b - alpha * b) in let zeta' = truncate_up p ((dmin + dmax) / 2) in let zeta = if l < 0 then - zeta' else zeta' in let delta = truncate_up p (zeta - dmin) in let res1 = trunc_bound_eucl p (alpha * fst X) in let res2 = trunc_bound_eucl p (fst res1 + zeta) in let zs = trunc_bound_pdevs p (scaleR_pdevs alpha (snd X)) in ((fst res2, fst zs), (sum_list' p [delta, snd res1, snd res2, snd zs])))" lemma inverse_aform'E: fixes X::"real aform" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes Inf_pos: "Inf_aform' p X > 0" assumes "x = aform_val e X" shows "inverse x ∈ aform_err e (inverse_aform' p X)" proof - define l where "l = Inf_aform' p X" define u where "u = Sup_aform' p X" define a where "a = min (abs l) (abs u)" define b where "b = max (abs l) (abs u)" define sq where "sq = truncate_up p (b * b)" define alpha where "alpha = - (real_divl p 1 sq)" define d_max' where "d_max' = truncate_up p (real_divr p 1 a - alpha * a)" define d_min' where "d_min' = truncate_down p (real_divl p 1 b - alpha * b)" define zeta where "zeta = truncate_up p ((d_min' + d_max') / 2)" define delta where "delta = truncate_up p (zeta - d_min')" note vars = l_def u_def a_def b_def sq_def alpha_def d_max'_def d_min'_def zeta_def delta_def let ?x = "aform_val e X" have "0 < l" using assms by (auto simp add: l_def Inf_aform_def) have "l ≤ u" by (auto simp: l_def u_def) hence a_def': "a = l" and b_def': "b = u" and "0 < a" "0 < b" using ‹0 < l› by (simp_all add: a_def b_def) have "0 < ?x" by (rule less_le_trans[OF Inf_pos order.trans[OF Inf_aform' Inf_aform], OF e]) have "a ≤ ?x" by (metis order.trans Inf_aform e Inf_aform' a_def' l_def) have "?x ≤ b" by (metis order.trans Sup_aform e Sup_aform' b_def' u_def) hence "?x ∈ {?x .. b}" by simp have "- inverse (b * b) ≤ alpha" by (auto simp add: alpha_def inverse_mult_distrib[symmetric] inverse_eq_divide sq_def intro!: order_trans[OF real_divl] divide_left_mono truncate_up mult_pos_pos ‹0 < b›) { note ‹0 < a› moreover have "?x ∈ {a .. b}" using ‹a ≤ ?x› ‹?x ≤ b› by simp moreover note ‹- inverse (b * b) ≤ alpha› ultimately have "inverse ?x ≤ inverse a + alpha * (?x - a)" by (rule inverse_linear_upper) also have "… = alpha * ?x + (inverse a - alpha * a)" by (simp add: algebra_simps) also have "inverse a - (alpha * a) ≤ (real_divr p 1 a - alpha * a)" by (auto simp: inverse_eq_divide real_divr) also have "… ≤ (truncate_down p (real_divl p 1 b - alpha * b) + (real_divr p 1 a - alpha * a)) / 2 + (truncate_up p (real_divr p 1 a - alpha * a) - truncate_down p (real_divl p 1 b - alpha * b)) / 2" (is "_ ≤ (truncate_down p ?lb + ?ra) / 2 + (truncate_up p ?ra - truncate_down p ?lb) / 2") by (auto simp add: field_simps intro!: order_trans[OF _ add_left_mono[OF mult_left_mono[OF truncate_up]]]) also have "(truncate_down p ?lb + ?ra) / 2 ≤ truncate_up p ((truncate_down p ?lb + truncate_up p ?ra) / 2)" by (intro truncate_up_le divide_right_mono add_left_mono truncate_up) auto also have "(truncate_up p ?ra - truncate_down p ?lb) / 2 + truncate_down p ?lb ≤ (truncate_up p ((truncate_down p ?lb + truncate_up p ?ra) / 2))" by (rule truncate_up_le) (simp add: field_simps) hence "(truncate_up p ?ra - truncate_down p ?lb) / 2 ≤ truncate_up p (truncate_up p ((truncate_down p ?lb + truncate_up p ?ra) / 2) - truncate_down p ?lb)" by (intro truncate_up_le) (simp add: field_simps) finally have "inverse ?x ≤ alpha * ?x + zeta + delta" by (auto simp: zeta_def delta_def d_min'_def d_max'_def right_diff_distrib ac_simps) } note upper = this { have "alpha * b + truncate_down p (real_divl p 1 b - alpha * b) ≤ inverse b" by (rule order_trans[OF add_left_mono[OF truncate_down]]) (auto simp: inverse_eq_divide real_divl) hence "zeta + alpha * b ≤ delta + inverse b" by (auto simp: zeta_def delta_def d_min'_def d_max'_def right_diff_distrib intro!: order_trans[OF _ add_right_mono[OF truncate_up]]) hence "alpha * ?x + zeta - delta ≤ inverse b + alpha * (?x - b)" by (simp add: algebra_simps) also { note ‹0 < aform_val e X› moreover note ‹aform_val e X ∈ {aform_val e X .. b}› moreover note ‹- inverse (b * b) ≤ alpha› ultimately have "inverse b + alpha * (aform_val e X - b) ≤ inverse (aform_val e X)" by (rule inverse_linear_lower) } finally have "alpha * (aform_val e X) + zeta - delta ≤ inverse (aform_val e X)" . } note lower = this have "inverse (aform_val e X) = alpha * (aform_val e X) + zeta + (inverse (aform_val e X) - alpha * (aform_val e X) - zeta)" (is "_ = _ + ?linerr") by simp also have "?linerr ∈ {- delta .. delta}" using lower upper by simp hence linerr_le: "abs ?linerr ≤ delta" by auto let ?z0 = "trunc_bound_eucl p (alpha * fst X)" from trunc_bound_euclE obtain e1 where abs_e1: "¦e1¦ ≤ snd ?z0" and e1: "fst ?z0 = alpha * fst X + e1" by blast let ?z1 = "trunc_bound_eucl p (fst ?z0 + zeta)" from trunc_bound_euclE obtain e1' where abs_e1': "¦e1'¦ ≤ snd ?z1" and e1': "fst ?z1 = fst ?z0 + zeta + e1'" by blast let ?zs = "trunc_bound_pdevs p (scaleR_pdevs alpha (snd X))" from trunc_bound_pdevsE[OF e] obtain e2 where abs_e2: "¦e2¦ ≤ snd (?zs)" and e2: "pdevs_val e (fst ?zs) = pdevs_val e (scaleR_pdevs alpha (snd X)) + e2" by blast have "alpha * (aform_val e X) + zeta = aform_val e (fst (inverse_aform' p X)) + (- e1 - e1' - e2)" unfolding inverse_aform'_def Let_def vars[symmetric] using ‹0 < l› by (simp add: aform_val_def assms e1') (simp add: e1 e2 algebra_simps) also let ?err = "(- e1 - e1' - e2 + inverse (aform_val e X) - alpha * aform_val e X - zeta)" { have "abs ?err ≤ abs ?linerr + abs e1 + abs e1' + abs e2" by simp also have "… ≤ delta + snd ?z0 + snd ?z1 + snd ?zs" by (blast intro: add_mono linerr_le abs_e1 abs_e1' abs_e2) also have "… ≤ (snd (inverse_aform' p X))" unfolding inverse_aform'_def Let_def vars[symmetric] using ‹0 < l› by (auto simp add: inverse_aform'_def pdevs_apply_trunc_pdevs assms vars[symmetric] intro!: order.trans[OF _ sum_list'_sum_list_le]) finally have "abs ?err ≤ snd (inverse_aform' p X)" by simp } note err_le = this have "aform_val (e) (fst (inverse_aform' p X)) + (- e1 - e1' - e2) + (inverse (aform_val e X) - alpha * aform_val e X - zeta) = aform_val e (fst (inverse_aform' p X)) + ?err" by simp finally show ?thesis apply (intro aform_errI) using err_le by (auto simp: assms) qed definition "inverse_aform p a = do { let l = Inf_aform' p a; let u = Sup_aform' p a; if (l ≤ 0 ∧ 0 ≤ u) then None else if (l ≤ 0) then (Some (apfst uminus_aform (inverse_aform' p (uminus_aform a)))) else Some (inverse_aform' p a) }" lemma eucl_truncate_up_eq_eucl_truncate_down: "eucl_truncate_up p x = - (eucl_truncate_down p (- x))" by (auto simp: eucl_truncate_up_def eucl_truncate_down_def truncate_up_eq_truncate_down sum_negf) lemma inverse_aformE: fixes X::"real aform" assumes e: "e ∈ UNIV → {-1 .. 1}" and disj: "Inf_aform' p X > 0 ∨ Sup_aform' p X < 0" obtains Y where "inverse_aform p X = Some Y" "inverse (aform_val e X) ∈ aform_err e Y" proof - { assume neg: "Sup_aform' p X < 0" from neg have [simp]: "Inf_aform' p X ≤ 0" by (metis Inf_aform'_le_Sup_aform' dual_order.strict_trans1 less_asym not_less) from neg disj have "0 < Inf_aform' p (uminus_aform X)" by (auto simp: Inf_aform'_def Sup_aform'_def eucl_truncate_up_eq_eucl_truncate_down ac_simps) from inverse_aform'E[OF e(1) this] have iin: "inverse (aform_val e (uminus_aform X)) ∈ aform_err e (inverse_aform' p (uminus_aform X))" by simp let ?Y = "apfst uminus_aform (inverse_aform' p (uminus_aform X))" have "inverse_aform p X = Some ?Y" "inverse (aform_val e X) ∈ aform_err e ?Y" using neg iin by (auto simp: inverse_aform_def aform_err_def) then have ?thesis .. } moreover { assume pos: "Inf_aform' p X > 0" from pos have eq: "inverse_aform p X = Some (inverse_aform' p X)" by (auto simp: inverse_aform_def) moreover from inverse_aform'E[OF e(1) pos refl] have "inverse (aform_val e X) ∈ aform_err e (inverse_aform' p X)" . ultimately have ?thesis .. } ultimately show ?thesis using assms by auto qed definition aform_err_to_aform::"aform_err ⇒ nat ⇒ real aform" where "aform_err_to_aform X n = (fst (fst X), pdev_upd (snd (fst X)) n (snd X))" lemma aform_err_to_aformE: assumes "x ∈ aform_err e X" assumes deg: "degree_aform_err X ≤ n" obtains err where "x = aform_val (e(n:=err)) (aform_err_to_aform X n)" "-1 ≤ err" "err ≤ 1" proof - from aform_errE[OF assms(1)] have "¦x - aform_val e (fst X)¦ ≤ snd X" by auto from error_absE[OF this] obtain err where err: "x - aform_val e (fst X) = err * snd X" "err ∈ {- 1..1}" by auto have "x = aform_val (e(n:=err)) (aform_err_to_aform X n)" "-1 ≤ err" "err ≤ 1" using err deg by (auto simp: aform_val_def aform_err_to_aform_def) then show ?thesis .. qed definition aform_to_aform_err::"real aform ⇒ nat ⇒ aform_err" where "aform_to_aform_err X n = ((fst X, pdev_upd (snd X) n 0), abs (pdevs_apply (snd X) n))" lemma aform_to_aform_err: "aform_val e X ∈ aform_err e (aform_to_aform_err X n)" if "e ∈ UNIV → {-1 .. 1}" proof - from that have abs_e[simp]: "⋀i. ¦e i¦ ≤ 1" by (auto simp: abs_real_def) have "- e n * pdevs_apply (snd X) n ≤ ¦pdevs_apply (snd X) n¦" proof - have "- e n * pdevs_apply (snd X) n ≤ ¦- e n * pdevs_apply (snd X) n¦" by auto also have "… ≤ abs (pdevs_apply (snd X) n)" using that by (auto simp: abs_mult intro!: mult_left_le_one_le) finally show ?thesis . qed moreover have "e n * pdevs_apply (snd X) n ≤ ¦pdevs_apply (snd X) n¦" proof - have "e n * pdevs_apply (snd X) n ≤ ¦e n * pdevs_apply (snd X) n¦" by auto also have "… ≤ abs (pdevs_apply (snd X) n)" using that by (auto simp: abs_mult intro!: mult_left_le_one_le) finally show ?thesis . qed ultimately show ?thesis by (auto simp: aform_to_aform_err_def aform_err_def aform_val_def) qed definition "acc_err p x e ≡ (fst x, truncate_up p (snd x + e))" definition ivl_err :: "real interval ⇒ (real × real pdevs) × real" where "ivl_err ivl ≡ (((upper ivl + lower ivl)/2, zero_pdevs::real pdevs), (upper ivl - lower ivl) / 2)" lemma inverse_aform: fixes X::"real aform" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes "inverse_aform p X = Some Y" shows "inverse (aform_val e X) ∈ aform_err e Y" proof - from assms have "Inf_aform' p X > 0 ∨ 0 > Sup_aform' p X" by (auto simp: inverse_aform_def Let_def bind_eq_Some_conv split: if_splits) from inverse_aformE[OF e this] obtain Y where "inverse_aform p X = Some Y" "inverse (aform_val e X) ∈ aform_err e Y" by auto with assms show ?thesis by auto qed lemma aform_err_acc_err_leI: "fx ∈ aform_err e (acc_err p X err)" if "aform_val e (fst X) - (snd X + err) ≤ fx" "fx ≤ aform_val e (fst X) + (snd X + err)" using truncate_up[of "(snd X + err)" p] truncate_down[of p "(snd X + err)"] that by (auto simp: aform_err_def acc_err_def) lemma aform_err_acc_errI: "fx ∈ aform_err e (acc_err p X err)" if "fx ∈ aform_err e (fst X, snd X + err)" using truncate_up[of "(snd X + err)" p] truncate_down[of p "(snd X + err)"] that by (auto simp: aform_err_def acc_err_def) lemma minus_times_le_abs: "- (err * B) ≤ ¦B¦" if "-1 ≤ err" "err ≤ 1" for err::real proof - have [simp]: "abs err ≤ 1" using that by (auto simp: ) have "- (err * B) ≤ abs (- err * B)" by auto also have "… ≤ abs B" by (auto simp: abs_mult intro!: mult_left_le_one_le) finally show ?thesis by simp qed lemma times_le_abs: "err * B ≤ ¦B¦" if "-1 ≤ err" "err ≤ 1" for err::real proof - have [simp]: "abs err ≤ 1" using that by (auto simp: ) have "err * B ≤ abs (err * B)" by auto also have "… ≤ abs B" by (auto simp: abs_mult intro!: mult_left_le_one_le) finally show ?thesis by simp qed lemma aform_err_lemma1: "- 1 ≤ err ⟹ err ≤ 1 ⟹ X1 + (A - e d * B + err * B) - e1 ≤ x ⟹ X1 + (A - e d * B) - truncate_up p (¦B¦ + e1) ≤ x" apply (rule order_trans) apply (rule diff_mono) apply (rule order_refl) apply (rule truncate_up_le[where x="e1 - err * B"]) by (auto simp: minus_times_le_abs) lemma aform_err_lemma2: "- 1 ≤ err ⟹ err ≤ 1 ⟹ x ≤ X1 + (A - e d * B + err * B) + e1 ⟹ x ≤ X1 + (A - e d * B) + truncate_up p (¦B¦ + e1)" apply (rule order_trans[rotated]) apply (rule add_mono) apply (rule order_refl) apply (rule truncate_up_le[where x="e1 + err * B"]) by (auto simp: times_le_abs) lemma aform_err_acc_err_aform_to_aform_errI: "x ∈ aform_err e (acc_err p (aform_to_aform_err X1 d) e1)" if "-1 ≤ err" "err ≤ 1" "x ∈ aform_err (e(d := err)) (X1, e1)" using that by (auto simp: acc_err_def aform_err_def aform_val_def aform_to_aform_err_def aform_err_to_aform_def aform_err_lemma1 aform_err_lemma2) definition "map_aform_err I p X = (do { let X0 = aform_err_to_aform X (degree_aform_err X); (X1, e1) ← I X0; Some (acc_err p (aform_to_aform_err X1 (degree_aform_err X)) e1) })" lemma map_aform_err: "i x ∈ aform_err e Y" if I: "⋀e X Y. e ∈ UNIV → {-1 .. 1} ⟹ I X = Some Y ⟹ i (aform_val e X) ∈ aform_err e Y" and e: "e ∈ UNIV → {-1 .. 1}" and Y: "map_aform_err I p X = Some Y" and x: "x ∈ aform_err e X" proof - obtain X1 e1 where X1: "(I (aform_err_to_aform X (degree_aform_err X))) = Some (X1, e1)" and Y: "Y = acc_err p (aform_to_aform_err X1 (degree_aform (fst X))) e1" using Y by (auto simp: map_aform_err_def bind_eq_Some_conv Let_def) from aform_err_to_aformE[OF x] obtain err where err: "x = aform_val (e(degree_aform_err X := err)) (aform_err_to_aform X (degree_aform_err X)) " (is "_ = aform_val ?e _") and "- 1 ≤ err" "err ≤ 1" by auto then have e': "?e ∈ UNIV → {-1 .. 1}" using e by auto from err have "i x = i (aform_val (e(degree_aform_err X := err)) (aform_err_to_aform X (degree_aform_err X)))" by simp also note I[OF e' X1] also have "aform_err (e(degree_aform_err X := err)) (X1, e1) ⊆ aform_err e Y" apply rule unfolding Y using ‹-1 ≤ err› ‹err ≤ 1› by (rule aform_err_acc_err_aform_to_aform_errI) finally show ?thesis . qed definition "inverse_aform_err p X = map_aform_err (inverse_aform p) p X" lemma inverse_aform_err: "inverse x ∈ aform_err e Y" if e: "e ∈ UNIV → {-1 .. 1}" and Y: "inverse_aform_err p X = Some Y" and x: "x ∈ aform_err e X" using map_aform_err[OF inverse_aform[where p=p] e Y[unfolded inverse_aform_err_def] x] by auto subsection ‹Reduction (Summarization of Coefficients)› text ‹\label{sec:affinesummarize}› definition "pdevs_of_centered_ivl r = (inner_scaleR_pdevs r One_pdevs)" lemma pdevs_of_centered_ivl_eq_pdevs_of_ivl[simp]: "pdevs_of_centered_ivl r = pdevs_of_ivl (-r) r" by (auto simp: pdevs_of_centered_ivl_def pdevs_of_ivl_def algebra_simps intro!: pdevs_eqI) lemma filter_pdevs_raw_nonzeros: "{i. filter_pdevs_raw s f i ≠ 0} = {i. f i ≠ 0} ∩ {x. s x (f x)}" by (auto simp: filter_pdevs_raw_def) definition summarize_pdevs:: "nat ⇒ (nat ⇒ 'a ⇒ bool) ⇒ nat ⇒ 'a::executable_euclidean_space pdevs ⇒ 'a pdevs" where "summarize_pdevs p I d x = (let t = tdev' p (filter_pdevs (-I) x) in msum_pdevs d (filter_pdevs I x) (pdevs_of_centered_ivl t))" definition summarize_threshold where "summarize_threshold p t x y ⟷ infnorm y ≥ t * infnorm (eucl_truncate_up p (tdev' p x))" lemma error_abs_euclE: fixes err::"'a::ordered_euclidean_space" assumes "abs err ≤ k" obtains e::"'a ⇒ real" where "err = (∑i∈Basis. (e i * (k ∙ i)) *⇩R i)" "e ∈ UNIV → {-1 .. 1}" proof atomize_elim { fix i::'a assume "i ∈ Basis" hence "abs (err ∙ i) ≤ (k ∙ i)" using assms by (auto simp add: eucl_le[where 'a='a] abs_inner) hence "∃e. (err ∙ i = e * (k ∙ i)) ∧ e ∈ {-1..1}" by (rule error_absE) auto } then obtain e where e: "⋀i. i ∈ Basis ⟹ err ∙ i = e i * (k ∙ i)" "⋀i. i ∈ Basis ⟹ e i ∈ {-1 .. 1}" by metis have singleton: "⋀b. b ∈ Basis ⟹ (∑i∈Basis. e i * (k ∙ i) * (if i = b then 1 else 0)) = (∑i∈{b}. e i * (k ∙ i) * (if i = b then 1 else 0))" by (rule sum.mono_neutral_cong_right) auto show "∃e::'a⇒real. err = (∑i∈Basis. (e i * (k ∙ i)) *⇩R i) ∧ (e ∈ UNIV → {-1..1})" using e by (auto intro!: exI[where x="λi. if i ∈ Basis then e i else 0"] euclidean_eqI[where 'a='a] simp: inner_sum_left inner_Basis singleton) qed lemma summarize_pdevsE: fixes x::"'a::executable_euclidean_space pdevs" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes d: "degree x ≤ d" obtains e' where "pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x)" "⋀i. i < d ⟹ e i = e' i" "e' ∈ UNIV → {-1 .. 1}" proof atomize_elim have "pdevs_val e x = (∑i<degree x. e i *⇩R pdevs_apply x i)" by (auto simp add: pdevs_val_sum intro!: sum.cong) also have "… = (∑i ∈ {..<degree x} ∩ {i. I i (pdevs_apply x i)}. e i *⇩R pdevs_apply x i) + (∑i∈ {..<degree x} - {i. I i (pdevs_apply x i)}. e i *⇩R pdevs_apply x i)" (is "_ = ?large + ?small") by (subst sum.union_disjoint[symmetric]) (auto simp: ac_simps intro!: sum.cong) also have "?large = pdevs_val e (filter_pdevs I x)" by (simp add: pdevs_val_filter_pdevs) also have "?small = pdevs_val e (filter_pdevs (-I) x)" by (simp add: pdevs_val_filter_pdevs Collect_neg_eq Diff_eq) also have "abs … ≤ tdev' p (filter_pdevs (-I) x)" (is "abs ?r ≤ ?t") using e by (rule abs_pdevs_val_le_tdev') hence "?r ∈ {-?t .. ?t}" by (metis abs_le_D1 abs_le_D2 atLeastAtMost_iff minus_le_iff) from in_ivl_affine_of_ivlE[OF this] obtain e2 where "?r = aform_val e2 (aform_of_ivl (- ?t) ?t)" and e2: "e2 ∈ UNIV → {- 1..1}" by metis note this(1) also define e' where "e' i = (if i < d then e i else e2 (i - d))" for i hence "aform_val e2 (aform_of_ivl (- ?t) ?t) = pdevs_val (λi. e' (i + d)) (pdevs_of_ivl (- ?t) ?t)" by (auto simp: aform_of_ivl_def aform_val_def) also have "pdevs_val e (filter_pdevs I x) = pdevs_val e' (filter_pdevs I x)" using assms by (auto simp: e'_def pdevs_val_sum intro!: sum.cong) finally have "pdevs_val e x = pdevs_val e' (filter_pdevs I x) + pdevs_val (λi. e' (i + d)) (pdevs_of_ivl (- ?t) ?t)" . also note pdevs_val_msum_pdevs[symmetric, OF order_trans[OF degree_filter_pdevs_le d]] finally have "pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x)" by (auto simp: summarize_pdevs_def Let_def) moreover have "e' ∈ UNIV → {-1 .. 1}" using e e2 by (auto simp: e'_def Pi_iff) moreover have "∀i < d. e' i = e i" by (auto simp: e'_def) ultimately show "∃e'. pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x) ∧ (∀i<d. e i = e' i) ∧ e' ∈ UNIV → {- 1..1}" by auto qed definition "summarize_pdevs_list p I d xs = map (λ(d, x). summarize_pdevs p (λi _. I i (pdevs_applys xs i)) d x) (zip [d..<d + length xs] xs)" lemma filter_pdevs_cong[cong]: assumes "x = y" assumes "⋀i. i ∈ pdevs_domain y ⟹ P i (pdevs_apply x i) = Q i (pdevs_apply y i)" shows "filter_pdevs P x = filter_pdevs Q y" using assms by (force intro!: pdevs_eqI) lemma summarize_pdevs_cong[cong]: assumes "p = q" "a = c" "b = d" assumes PQ: "⋀i. i ∈ pdevs_domain d ⟹ P i (pdevs_apply b i) = Q i (pdevs_apply d i)" shows "summarize_pdevs p P a b = summarize_pdevs q Q c d" proof - have "(filter_pdevs P b) = filter_pdevs Q d" "(filter_pdevs (λa b. ¬ P a b) b) = filter_pdevs (λa b. ¬ Q a b) d" using assms by (auto intro!: filter_pdevs_cong) then show ?thesis by (auto simp add: assms summarize_pdevs_def Let_def) qed lemma lookup_eq_None_iff: "(Mapping.lookup M x = None) = (x ∉ Mapping.keys M)" by (transfer) auto lemma lookup_eq_SomeD: "(Mapping.lookup M x = Some y) ⟹ (x ∈ Mapping.keys M)" by transfer auto definition "domain_pdevs xs = (⋃(pdevs_domain ` (set xs)))" definition "pdevs_mapping xs = (let D = sorted_list_of_set (domain_pdevs xs); M = Mapping.tabulate D (pdevs_applys xs); zeroes = replicate (length xs) 0 in Mapping.lookup_default zeroes M)" lemma pdevs_mapping_eq[simp]: "pdevs_mapping xs = pdevs_applys xs" unfolding pdevs_mapping_def pdevs_applys_def apply (auto simp: Mapping.lookup_default_def lookup_eq_None_iff domain_pdevs_def split: option.splits intro!: ext) subgoal by (auto intro!: nth_equalityI) subgoal apply (auto intro!: nth_equalityI dest: ) subgoal apply (frule lookup_eq_SomeD) apply auto by (metis distinct_sorted_list_of_set keys_tabulate length_map lookup_eq_SomeD lookup_tabulate option.inject) subgoal apply (frule lookup_eq_SomeD) apply (auto simp: map_nth) by (metis (mono_tags, lifting) keys_tabulate lookup_eq_SomeD lookup_tabulate option.inject distinct_sorted_list_of_set) done done lemma compute_summarize_pdevs_list[code]: "summarize_pdevs_list p I d xs = (let M = pdevs_mapping xs in map (λ(x, y). summarize_pdevs p (λi _. I i (M i)) x y) (zip [d..<d + length xs] xs))" unfolding summarize_pdevs_list_def pdevs_mapping_eq by auto lemma in_centered_ivlE: fixes r t::real assumes "r ∈ {-t .. t}" obtains e where "e ∈ {-1 .. 1}" "r = e * t" using assms by (atomize_elim) (auto intro!: exI[where x="r / t"] simp: divide_simps) lift_definition singleton_pdevs::"'a ⇒ 'a::real_normed_vector pdevs" is "λx i. if i = 0 then x else 0" by auto lemmas [simp] = singleton_pdevs.rep_eq lemma singleton_0[simp]: "singleton_pdevs 0 = zero_pdevs" by (auto intro!: pdevs_eqI) lemma degree_singleton_pdevs[simp]: "degree (singleton_pdevs x) = (if x = 0 then 0 else Suc 0)" by (auto simp: intro!: degree_eqI) lemma pdevs_val_singleton_pdevs[simp]: "pdevs_val e (singleton_pdevs x) = e 0 *⇩R x" by (auto simp: pdevs_val_sum if_distrib sum.delta cong: if_cong) lemma pdevs_of_ivl_real: fixes a b::real shows "pdevs_of_ivl a b = singleton_pdevs ((b - a) / 2)" by (auto simp: pdevs_of_ivl_def Basis_list_real_def intro!: pdevs_eqI) lemma summarize_pdevs_listE: fixes X::"real pdevs list" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes d: "degrees X ≤ d" obtains e' where "pdevs_vals e X = pdevs_vals e' (summarize_pdevs_list p I d X)" "⋀i. i < d ⟹ e i = e' i" "e' ∈ UNIV → {-1 .. 1}" proof - let ?I = "{i. I i (pdevs_applys X i)}" let ?J = "λi x. I i (pdevs_applys X i)" have "pdevs_vals e X = map (λx. ∑i<degree x. e i *⇩R pdevs_apply x i) X" using d by (auto simp: pdevs_vals_def simp del: real_scaleR_def intro!: pdevs_val_sum_le dest!: degrees_leD) also have "… = map (λx. (∑i∈{..<degree x} ∩ ?I. e i * pdevs_apply x i) + (∑i∈{..<degree x} - ?I. e i * pdevs_apply x i)) X" by (rule map_cong[OF refl], subst sum.union_disjoint[symmetric]) (auto intro!: sum.cong) also have "… = map (λx. pdevs_val e (filter_pdevs ?J x) + pdevs_val e (filter_pdevs (-?J) x)) X" (is "_ = map (λx. ?large x + ?small x) _") by (auto simp: pdevs_val_filter_pdevs Diff_eq Compl_eq) also have "… = map snd (zip [d..<d + length X] …)" by simp also have "… = map (λ(d, x). ?large x + ?small x) (zip [d..<d + length X] X)" (is "_ = map _ ?z") unfolding map_zip_map2 by simp also have "… = map (λ(d', x). ?large x + ?small (snd (?z ! (d' - d)))) ?z" by (auto simp: in_set_zip) also let ?t = "λx. tdev' p (filter_pdevs (-?J) x)" let ?x = "λd'. snd (?z ! (d' - d))" { fix d' assume "d ≤ d'" "d' < d + length X" have "abs (?small (?x d')) ≤ ?t (?x d')" using ‹e ∈ _› by (rule abs_pdevs_val_le_tdev') then have "?small (?x d') ∈ {-?t (?x d') .. ?t (?x d')}" by auto from in_centered_ivlE[OF this] have "∃e∈{-1 .. 1}. ?small (?x d') = e * ?t (?x d')" by blast } then obtain e'' where e'': "e'' d' ∈ {-1 .. 1}" "?small (?x d') = e'' d' * ?t (?x d')" if "d' ∈ {d ..< d + length X}" for d' apply atomize_elim unfolding all_conj_distrib[symmetric] imp_conjR[symmetric] unfolding Ball_def[symmetric] atLeastAtMost_iff[symmetric] apply (rule bchoice) apply (auto simp: Bex_def ) done define e' where "e' ≡ λi. if i < d then e i else if i < d + length X then e'' i else 0" have e': "e' d' ∈ {-1 .. 1}" "?small (?x d') = e' d' * ?t (?x d')" if "d' ∈ {d ..< d + length X}" for d' using e'' that by (auto simp: e'_def split: if_splits) then have *: "pdevs_val e (filter_pdevs (λa b. ¬ I a (pdevs_applys X a)) (?x d')) = e' d' * ?t (?x d')" if "d' ∈ {d ..< d + length X}" for d' using that by auto have "map (λ(d', x). ?large x + ?small (?x d')) ?z = map (λ(d', x). ?large x + e' d' * ?t (?x d')) ?z" apply (auto simp: in_set_zip) subgoal for n using e'(2)[of "d + n"] by auto done also have "… = map (λ(d', x). pdevs_val e' (summarize_pdevs p ?J d' x)) (zip [d..<d + length X] X)" apply (auto simp: summarize_pdevs_def pdevs_val_msum_pdevs Let_def in_set_zip) apply (subst pdevs_val_msum_pdevs) using d apply (auto intro!: degree_filter_pdevs_le[THEN order_trans]) subgoal by (auto dest!: degrees_leD nth_mem) apply (auto simp: pdevs_of_ivl_real intro!: ) subgoal premises prems proof - have "degree (filter_pdevs (λi x. I i (pdevs_applys X i)) (X ! n)) ≤ d" if "n < length X" for n using d that by (intro degree_filter_pdevs_le[THEN order_trans]) (simp add: degrees_leD) then show ?thesis using prems e'' apply (intro pdevs_val_degree_cong) apply (auto dest!: ) apply (auto simp: e'_def) apply (meson ‹⋀n. ⟦n < length X; degrees X ≤ d⟧ ⟹ degree (X ! n) ≤ d + n› degree_filter_pdevs_le less_le_trans) by (meson less_le_trans trans_less_add1) qed done also have "… = pdevs_vals e' (summarize_pdevs_list p I d X)" by (auto simp: summarize_pdevs_list_def pdevs_vals_def) finally have "pdevs_vals e X = pdevs_vals e' (summarize_pdevs_list p I d X)" . moreover have "(⋀i. i < d ⟹ e i = e' i)" "e' ∈ UNIV → {- 1..1}" using ‹e ∈ _› e'' by (auto simp: e'_def) ultimately show ?thesis .. qed fun list_ex2 where "list_ex2 P [] xs = False" | "list_ex2 P xs [] = False" | "list_ex2 P (x#xs) (y#ys) = (P x y ∨ list_ex2 P xs ys)" lemma list_ex2_iff: "list_ex2 P xs ys ⟷ (¬list_all2 (-P) (take (length ys) xs) (take (length xs) ys))" by (induction P xs ys rule: list_ex2.induct) auto definition "summarize_aforms p C d (X::real aform list) = (zip (map fst X) (summarize_pdevs_list p (C X) d (map snd X)))" lemma aform_vals_pdevs_vals: "aform_vals e X = map (λ(x, y). x + y) (zip (map fst X) (pdevs_vals e (map snd X)))" by (auto simp: pdevs_vals_def aform_vals_def aform_val_def[abs_def] map_zip_map map_zip_map2 split_beta' zip_same_conv_map) lemma summarize_aformsE: fixes X::"real aform list" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes d: "degree_aforms X ≤ d" obtains e' where "aform_vals e X = aform_vals e' (summarize_aforms p C d X)" "⋀i. i < d ⟹ e i = e' i" "e' ∈ UNIV → {-1 .. 1}" proof - define Xs where "Xs = map snd X" have "aform_vals e X = map (λ(x, y). x + y) (zip (map fst X) (pdevs_vals e Xs))" by (auto simp: aform_vals_pdevs_vals Xs_def) also obtain e' where e': "e' ∈ UNIV → {-1 .. 1}" "⋀i. i < d ⟹ e i = e' i" "pdevs_vals e Xs = pdevs_vals e' (summarize_pdevs_list p (C X) d Xs)" using summarize_pdevs_listE[OF e d, of p "C X"] by (metis Xs_def) note this(3) also have "map (λ(x, y). x + y) (zip (map fst X) …) = aform_vals e' (summarize_aforms p C d X)" unfolding aform_vals_pdevs_vals by (simp add: summarize_aforms_def Let_def Xs_def summarize_pdevs_list_def split_beta') finally have "aform_vals e X = aform_vals e' (summarize_aforms p C d X)" "⋀i. i < d ⟹ e i = e' i" "e' ∈ UNIV → {-1 .. 1}" using e' d by (auto simp: Xs_def) then show ?thesis .. qed text ‹Different reduction strategies:› definition "collect_threshold p ta t (X::real aform list) = (let Xs = map snd X; as = map (λX. max ta (t * tdev' p X)) Xs in (λ(i::nat) xs. list_ex2 (≤) as (map abs xs)))" definition "collect_girard p m (X::real aform list) = (let Xs = map snd X; M = pdevs_mapping Xs; D = domain_pdevs Xs; N = length X in if card D ≤ m then (λ_ _. True) else let Ds = sorted_list_of_set D; ortho_indices = map fst (take (2 * N) (sort_key (λ(i, r). r) (map (λi. let xs = M i in (i, sum_list' p xs - fold max xs 0)) Ds))); _ = () in (λi (xs::real list). i ∈ set ortho_indices))" subsection ‹Splitting with heuristics› definition "abs_pdevs = unop_pdevs abs" definition "abssum_of_pdevs_list X = fold (λa b. (add_pdevs (abs_pdevs a) b)) X zero_pdevs" definition "split_aforms xs i = (let splits = map (λx. split_aform x i) xs in (map fst splits, map snd splits))" definition "split_aforms_largest_uncond X = (let (i, x) = max_pdev (abssum_of_pdevs_list (map snd X)) in split_aforms X i)" definition "Inf_aform_err p Rd = (float_of (truncate_down p (Inf_aform' p (fst Rd) - abs(snd Rd))))" definition "Sup_aform_err p Rd = (float_of (truncate_up p (Sup_aform' p (fst Rd) + abs(snd Rd))))" context includes interval.lifting begin lift_definition ivl_of_aform_err::"nat ⇒ aform_err ⇒ float interval" is "λp Rd. (Inf_aform_err p Rd, Sup_aform_err p Rd)" by (auto simp: aform_err_def Inf_aform_err_def Sup_aform_err_def intro!: truncate_down_le truncate_up_le add_increasing[OF _ Inf_aform'_le_Sup_aform']) lemma lower_ivl_of_aform_err: "lower (ivl_of_aform_err p Rd) = Inf_aform_err p Rd" and upper_ivl_of_aform_err: "upper (ivl_of_aform_err p Rd) = Sup_aform_err p Rd" by (transfer, simp)+ end definition approx_un::"nat ⇒ (float interval ⇒ float interval option) ⇒ ((real × real pdevs) × real) option ⇒ ((real × real pdevs) × real) option" where "approx_un p f a = do { rd ← a; ivl ← f (ivl_of_aform_err p rd); Some (ivl_err (real_interval ivl)) }" definition interval_extension1::"(float interval ⇒ (float interval) option) ⇒ (real ⇒ real) ⇒ bool" where "interval_extension1 F f ⟷ (∀ivl ivl'. F ivl = Some ivl' ⟶ (∀x. x ∈⇩r ivl ⟶ f x ∈⇩r ivl'))" lemma interval_extension1D: assumes "interval_extension1 F f" assumes "F ivl = Some ivl'" assumes "x ∈⇩r ivl" shows "f x ∈⇩r ivl'" using assms by (auto simp: interval_extension1_def) lemma approx_un_argE: assumes au: "approx_un p F X = Some Y" obtains X' where "X = Some X'" using assms by (auto simp: approx_un_def bind_eq_Some_conv) lemma degree_aform_independent_from: "degree_aform (independent_from d1 X) ≤ d1 + degree_aform X" by (auto simp: independent_from_def degree_msum_pdevs_le) lemma degree_aform_of_ivl: fixes a b::"'a::executable_euclidean_space" shows "degree_aform (aform_of_ivl a b) ≤ length (Basis_list::'a list)" by (auto simp: aform_of_ivl_def degree_pdevs_of_ivl_le) lemma aform_err_ivl_err[simp]: "aform_err e (ivl_err ivl') = set_of ivl'" by (auto simp: aform_err_def ivl_err_def aform_val_def divide_simps set_of_eq) lemma Inf_Sup_aform_err: fixes X assumes e: "e ∈ UNIV → {-1 .. 1}" defines "X' ≡ fst X" shows "aform_err e X ⊆ {Inf_aform_err p X .. Sup_aform_err p X}" using Inf_aform[OF e, of X'] Sup_aform[OF e, of X'] Inf_aform'[of p X'] Sup_aform'[of X' p] by (auto simp: aform_err_def X'_def Inf_aform_err_def Sup_aform_err_def intro!: truncate_down_le truncate_up_le) lemma ivl_of_aform_err: fixes X assumes e: "e ∈ UNIV → {-1 .. 1}" shows "x ∈ aform_err e X ⟹ x ∈⇩r ivl_of_aform_err p X" using Inf_Sup_aform_err[OF e, of X p] by (auto simp: set_of_eq lower_ivl_of_aform_err upper_ivl_of_aform_err) lemma approx_unE: assumes ie: "interval_extension1 F f" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes au: "approx_un p F X'err = Some Ye" assumes x: "case X'err of None ⇒ True | Some X'err ⇒ x ∈ aform_err e X'err" shows "f x ∈ aform_err e Ye" proof - from au obtain ivl' X' err where F: "F (ivl_of_aform_err p (X', err)) = Some (ivl')" and Y: "Ye = ivl_err (real_interval ivl')" and X'err: "X'err = Some (X', err)" by (auto simp: approx_un_def bind_eq_Some_conv) from x have "x ∈ aform_err e (X', err)" by (auto simp: X'err) from ivl_of_aform_err[OF e this] have "x ∈⇩r ivl_of_aform_err p (X', err)" . from interval_extension1D[OF ie F this] have "f x ∈⇩r ivl'" . also have "… = aform_err e Ye" unfolding Y aform_err_ivl_err .. finally show ?thesis . qed definition "approx_bin p f rd sd = do { ivl ← f (ivl_of_aform_err p rd) (ivl_of_aform_err p sd); Some (ivl_err (real_interval ivl)) }" definition interval_extension2::"(float interval ⇒ float interval ⇒ float interval option) ⇒ (real ⇒ real ⇒ real) ⇒ bool" where "interval_extension2 F f ⟷ (∀ivl1 ivl2 ivl. F ivl1 ivl2 = Some ivl ⟶ (∀x y. x ∈⇩r ivl1 ⟶ y ∈⇩r ivl2 ⟶ f x y ∈⇩r ivl))" lemma interval_extension2D: assumes "interval_extension2 F f" assumes "F ivl1 ivl2 = Some ivl" shows "x ∈⇩r ivl1 ⟹ y ∈⇩r ivl2 ⟹ f x y ∈⇩r ivl" using assms by (auto simp: interval_extension2_def) lemma approx_binE: assumes ie: "interval_extension2 F f" assumes w: "w ∈ aform_err e (W', errw)" assumes x: "x ∈ aform_err e (X', errx)" assumes ab: "approx_bin p F ((W', errw)) ((X', errx)) = Some Ye" assumes e: "e ∈ UNIV → {-1 .. 1}" shows "f w x ∈ aform_err e Ye" proof - from ab obtain ivl' where F: "F (ivl_of_aform_err p (W', errw)) (ivl_of_aform_err p (X', errx)) = Some ivl'" and Y: "Ye = ivl_err (real_interval ivl')" by (auto simp: approx_bin_def bind_eq_Some_conv max_def) from interval_extension2D[OF ie F ivl_of_aform_err[OF e, where p=p, OF w] ivl_of_aform_err[OF e, where p=p, OF x]] have "f w x ∈⇩r ivl'" . also have "… = aform_err e Ye" unfolding Y aform_err_ivl_err .. finally show ?thesis . qed definition "min_aform_err p a1 (a2::aform_err) = (let ivl1 = ivl_of_aform_err p a1; ivl2 = ivl_of_aform_err p a2 in if upper ivl1 < lower ivl2 then a1 else if upper ivl2 < lower ivl1 then a2 else ivl_err (real_interval (min_interval ivl1 ivl2)))" definition "max_aform_err p a1 (a2::aform_err) = (let ivl1 = ivl_of_aform_err p a1; ivl2 = ivl_of_aform_err p a2 in if upper ivl1 < lower ivl2 then a2 else if upper ivl2 < lower ivl1 then a1 else ivl_err (real_interval (max_interval ivl1 ivl2)))" subsection ‹Approximate Min Range - Kind Of Trigonometric Functions› definition affine_unop :: "nat ⇒ real ⇒ real ⇒ real ⇒ aform_err ⇒ aform_err" where "affine_unop p a b d X = (let ((x, xs), xe) = X; (ax, axe) = trunc_bound_eucl p (a * x); (y, ye) = trunc_bound_eucl p (ax + b); (ys, yse) = trunc_bound_pdevs p (scaleR_pdevs a xs) in ((y, ys), sum_list' p [truncate_up p (¦a¦ * xe), axe, ye, yse, d]))" ― ‹TODO: also do binop› lemma aform_err_leI: "y ∈ aform_err e (c, d)" if "y ∈ aform_err e (c, d')" "d' ≤ d" using that by (auto simp: aform_err_def) lemma aform_err_eqI: "y ∈ aform_err e (c, d)" if "y ∈ aform_err e (c, d')" "d' = d" using that by (auto simp: aform_err_def) lemma sum_list'_append[simp]: "sum_list' p (ds@[d]) = truncate_up p (d + sum_list' p ds)" unfolding sum_list'_def by (simp add: eucl_truncate_up_real_def) lemma aform_err_sum_list': "y ∈ aform_err e (c, sum_list' p ds)" if "y ∈ aform_err e (c, sum_list ds)" using that(1) apply (rule aform_err_leI) by (rule sum_list_le_sum_list') lemma aform_err_trunc_bound_eucl: "y ∈ aform_err e ((fst (trunc_bound_eucl p X), xs), snd (trunc_bound_eucl p X) + d)" if y: "y ∈ aform_err e ((X, xs), d)" using that proof - from aform_errE[OF y] have "¦y - aform_val e (X, xs)¦ ≤ d" by auto then show ?thesis apply (intro aform_errI) apply (rule trunc_bound_euclE[of p X]) by (auto simp: aform_val_def) qed lemma trunc_err_pdevsE: assumes "e ∈ UNIV → {-1 .. 1}" obtains err where "¦err¦ ≤ tdev' p (trunc_err_pdevs p xs)" "pdevs_val e (trunc_pdevs p xs) = pdevs_val e xs + err" using trunc_bound_pdevsE[of e p xs] by (auto simp: trunc_bound_pdevs_def assms) lemma aform_err_trunc_bound_pdevsI: "y ∈ aform_err e ((c, fst (trunc_bound_pdevs p xs)), snd (trunc_bound_pdevs p xs) + d)" if y: "y ∈ aform_err e ((c, xs), d)" and e: "e ∈ UNIV → {-1 .. 1}" using that proof - define exs where "exs = trunc_err_pdevs p xs" from aform_errE[OF y] have "¦y - aform_val e (c, xs)¦ ≤ d" by auto then show ?thesis apply (intro aform_errI) apply (rule trunc_err_pdevsE[OF e, of p xs]) by (auto simp: aform_val_def trunc_bound_pdevs_def) qed lemma aform_err_addI: "y ∈ aform_err e ((a + b, xs), d)" if "y - b ∈ aform_err e ((a, xs), d)" using that by (auto simp: aform_err_def aform_val_def) theorem affine_unop: assumes x: "x ∈ aform_err e X" assumes f: "¦f x - (a * x + b)¦ ≤ d" and e: "e ∈ UNIV → {-1 .. 1}" shows "f x ∈ aform_err e (affine_unop p a b d X)" proof - show ?thesis unfolding affine_unop_def Let_def apply (auto simp: split_beta') apply (rule aform_err_sum_list') apply simp apply (rule aform_err_eqI) apply (rule aform_err_trunc_bound_eucl) apply (rule aform_err_addI) apply (rule aform_err_trunc_bound_eucl) apply (rule aform_err_trunc_bound_pdevsI) using e apply auto apply (rule aform_errI) apply (auto simp: aform_val_def) proof - define x' where "x' = (fst (fst X) + pdevs_val e (snd (fst X)))" have x_x': "¦x - x'¦ ≤ snd X" using aform_errE[OF x] by (auto simp: x'_def aform_val_def) have "¦f x - b - (a * fst (fst X) + a * pdevs_val e (snd (fst X)))¦ = ¦f x - (a * x + b) + a * (x - x')¦" by (simp add: algebra_simps x'_def) also have "… ≤ ¦f x - (a * x + b)¦ + ¦a * (x - x')¦" by (rule abs_triangle_ineq) also note f also have "¦a * (x - x')¦ ≤ truncate_up p (¦a¦ * snd X)" by (rule truncate_up_le) (auto simp: abs_mult intro!: mult_left_mono x_x') finally show "¦f x - b - (a * fst (fst X) + a * pdevs_val e (snd (fst X)))¦ ≤ truncate_up p (¦a¦ * snd X) + d" by auto qed qed lemma min_range_coeffs_ge: "¦f x - (a * x + b)¦ ≤ d" if l: "l ≤ x" and u: "x ≤ u" and f': "⋀y. y ∈ {l .. u} ⟹ (f has_real_derivative f' y) (at y)" and a: "⋀y. y ∈ {l..u} ⟹ a ≤ f' y" and d: "d ≥ (f u - f l - a * (u - l)) / 2 + ¦(f l + f u - a * (l + u)) / 2 - b¦" for a b d::real proof (rule order_trans[OF _ d]) note f'_at = has_field_derivative_at_within[OF f'] from l u have lu: "x ∈ {l .. u}" and llu: "l ∈ {l .. u}" by simp_all define m where "m = (f l + f u - a * (l + u)) / 2" have "¦f x - (a * x + b)¦ = ¦f x - (a * x + m) + (m - b)¦" by (simp add: algebra_simps) also have "… ≤ ¦f x - (a * x + m)¦ + ¦m - b¦" by (rule abs_triangle_ineq) also have "¦f x - (a * x + m)¦ ≤ (f u - f l - a * (u - l)) / 2" proof (rule abs_leI) have "f x ≥ f l + a * (x - l)" (is "?l ≥ ?r") apply (rule order_trans) prefer 2 apply (rule linear_lower2[OF f'_at, of l u a]) subgoal by assumption subgoal by (rule a) subgoal using lu by (auto intro!: mult_right_mono) subgoal using lu by auto done also have "a * x + m - (f u - f l - a * (u - l)) / 2 ≤ ?r" by (simp add: algebra_simps m_def field_simps) finally (xtrans) show "- (f x - (a * x + m)) ≤ (f u - f l - a * (u - l)) / 2" by (simp add: algebra_simps m_def divide_simps) next have "f x ≤ f u + a * (x - u)" apply (rule order_trans) apply (rule linear_upper2[OF f'_at, of l u a]) subgoal by assumption subgoal by (rule a) subgoal using lu by (auto intro!: mult_right_mono) subgoal using lu by auto done also have "… ≤ a * x + m + (f u - f l - a * (u - l)) / 2" by (simp add: m_def divide_simps algebra_simps) finally show "f x - (a * x + m) ≤ (f u - f l - a * (u - l)) / 2" by (simp add: algebra_simps m_def divide_simps) qed also have "¦m - b¦ = abs ((f l + f u - a * (l + u)) / 2 - b)" unfolding m_def .. finally show "¦f x - (a * x + b)¦ ≤ (f u - f l - a * (u - l)) / 2 + ¦(f l + f u - a * (l + u)) / 2 - b¦" by (simp) qed lemma min_range_coeffs_le: "¦f x - (a * x + b)¦ ≤ d" if l: "l ≤ x" and u: "x ≤ u" and f': "⋀y. y ∈ {l .. u} ⟹ (f has_real_derivative f' y) (at y)" and a: "⋀y. y ∈ {l .. u} ⟹ f' y ≤ a" and d: "d ≥ (f l - f u + a * (u - l)) / 2 + ¦(f l + f u - a * (l + u)) / 2 - b¦" for a b d::real proof (rule order_trans[OF _ d]) note f'_at = has_field_derivative_at_within[OF f'] from l u have lu: "x ∈ {l .. u}" and llu: "l ∈ {l .. u}" by simp_all define m where "m = (f l + f u - a * (l + u)) / 2" have "¦f x - (a * x + b)¦ = ¦f x - (a * x + m) + (m - b)¦" by (simp add: algebra_simps) also have "… ≤ ¦f x - (a * x + m)¦ + ¦m - b¦" by (rule abs_triangle_ineq) also have "¦f x - (a * x + m)¦ ≤ (f l - f u + a * (u - l)) / 2" proof (rule abs_leI) have "f x ≥ f u + a * (x - u)" (is "?l ≥ ?r") apply (rule order_trans) prefer 2 apply (rule linear_lower[OF f'_at, of l u a]) subgoal by assumption subgoal by (rule a) subgoal using lu by (auto intro!: mult_right_mono) subgoal using lu by auto done also have "a * x + m - (f l - f u + a * (u - l)) / 2 ≤ ?r" using lu by (auto simp add: algebra_simps m_def field_simps intro!: mult_left_mono_neg) finally (xtrans) show "- (f x - (a * x + m)) ≤ (f l - f u + a * (u - l)) / 2" by (simp add: algebra_simps m_def divide_simps) next have "f x ≤ f l + a * (x - l)" apply (rule order_trans) apply (rule linear_upper[OF f'_at, of l u a]) subgoal by assumption subgoal by (rule a) subgoal using lu by (auto intro!: mult_right_mono) subgoal using lu by auto done also have "… ≤ a * x + m + (f l - f u + a * (u - l)) / 2" using lu by (auto simp add: algebra_simps m_def field_simps intro!: mult_left_mono_neg) finally show "f x - (a * x + m) ≤ (f l - f u + a * (u - l)) / 2" by (simp add: algebra_simps m_def divide_simps) qed also have "¦m - b¦ = abs ((f l + f u - a * (l + u)) / 2 - b)" unfolding m_def .. finally show "¦f x - (a * x + b)¦ ≤ (f l - f u + a * (u - l)) / 2 + ¦(f l + f u - a * (l + u)) / 2 - b¦" by (simp) qed context includes floatarith_notation begin definition "range_reducer p l = (if l < 0 ∨ l > 2 * lb_pi p then approx p (Pi * (Num (-2)) * (Floor (Num (l * Float 1 (-1)) / Pi))) [] else Some 0)" lemmas approx_emptyD = approx[OF bounded_by_None[of Nil], simplified] lemma range_reducerE: assumes "range_reducer p l = Some ivl" obtains n::int where "n * (2 * pi) ∈⇩r ivl" proof (cases "l ≥ 0 ∧ l ≤ 2 * lb_pi p") case False with assms have "- ⌊l / (2 * pi)⌋ * (2 * pi) ∈⇩r ivl" by (auto simp: range_reducer_def bind_eq_Some_conv inverse_eq_divide algebra_simps dest!: approx_emptyD) then show ?thesis .. next case True then have "real_of_int 0 * (2 * pi) ∈⇩r ivl" using assms by (auto simp: range_reducer_def zero_in_float_intervalI) then show ?thesis .. qed definition "range_reduce_aform_err p X = do { r ← range_reducer p (lower (ivl_of_aform_err p X)); Some (add_aform' p X (ivl_err (real_interval r))) }" lemma range_reduce_aform_errE: assumes e: "e ∈ UNIV → {-1 .. 1}" assumes x: "x ∈ aform_err e X" assumes "range_reduce_aform_err p X = Some Y" obtains n::int where "x + n * (2 * pi) ∈ aform_err e Y" proof - from assms obtain r where x: "x ∈ aform_err e X" and r: "range_reducer p (lower (ivl_of_aform_err p X)) = Some r" and Y: "Y = add_aform' p X (ivl_err (real_interval r))" by (auto simp: range_reduce_aform_err_def bind_eq_Some_conv mid_err_def split: prod.splits) from range_reducerE[OF r] obtain n::int where "n * (2 * pi) ∈⇩r r" by auto then have "n * (2 * pi) ∈ aform_err e (ivl_err (real_interval r))" by (auto simp: aform_val_def ac_simps divide_simps abs_real_def set_of_eq intro!: aform_errI) from add_aform'[OF e x this, of p] have "x + n * (2 * pi) ∈ aform_err e Y" by (auto simp: Y) then show ?thesis .. qed definition "min_range_mono p F DF l u X = do { let L = Num l; let U = Num u; aivl ← approx p (Min (DF L) (DF U)) []; let a = lower aivl; let A = Num a; bivl ← approx p (Half (F L + F U - A * (L + U))) []; let (b, be) = mid_err bivl; let (B, Be) = (Num (float_of b), Num (float_of be)); divl ← approx p ((Half (F U - F L - A * (U - L))) + Be) []; Some (affine_unop p a b (real_of_float (upper divl)) X) }" lemma min_range_mono: assumes x: "x ∈ aform_err e X" assumes "l ≤ x" "x ≤ u" assumes "min_range_mono p F DF l u X = Some Y" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes F: "⋀x. x ∈ {real_of_float l .. u} ⟹ interpret_floatarith (F (Num x)) [] = f x" assumes DF: "⋀x. x ∈ {real_of_float l .. u} ⟹ interpret_floatarith (DF (Num x)) [] = f' x" assumes f': "⋀x. x ∈ {real_of_float l .. u} ⟹ (f has_real_derivative f' x) (at x)" assumes f'_le: "⋀x. x ∈ {real_of_float l .. u} ⟹ min (f' l) (f' u) ≤ f' x" shows "f x ∈ aform_err e Y" proof - from assms obtain a b be bivl divl where bivl: "(f l + f u - a * (l + u))/2 ∈⇩r bivl" and Y: "Y = affine_unop p a b (upper divl) X" and du: "(f u - f l - a * (u - l)) / 2 + be ∈⇩r divl" and a: "a ≤ f' l" "a ≤ f' u" and b_def: "b = (lower bivl + upper bivl) / 2" and be_def: "be = (upper bivl - lower bivl) / 2" by (auto simp: min_range_mono_def Let_def bind_eq_Some_conv mid_err_def set_of_eq simp del: eq_divide_eq_numeral1 split: prod.splits if_splits dest!: approx_emptyD) have diff_le: "real_of_float a ≤ f' y" if "real_of_float l ≤ y" "y ≤ u" for y using f'_le[of y] that a by auto have le_be: "¦(f (l) + f (u) - a * (real_of_float l + u)) / 2 - b¦ ≤ be" using bivl unfolding b_def be_def by (auto simp: abs_real_def divide_simps set_of_eq) have "¦f x - (a * x + b)¦ ≤ upper divl" apply (rule min_range_coeffs_ge) apply (rule ‹l ≤ x›) apply (rule ‹x ≤ u›) apply (rule f') apply assumption using diff_le apply force apply (rule order_trans[OF add_mono[OF order_refl]]) apply (rule le_be) using bivl du unfolding b_def[symmetric] be_def[symmetric] by (auto simp: set_of_eq) from affine_unop[where f=f and p = p, OF ‹x ∈ _› this e] have "f x ∈ aform_err e (affine_unop p (real_of_float a) b (upper divl) X)" by (auto simp: Y) then show ?thesis by (simp add: Y b_def) qed definition "min_range_antimono p F DF l u X = do { let L = Num l; let U = Num u; aivl ← approx p (Max (DF L) (DF U)) []; let a = upper aivl; let A = Num a; bivl ← approx p (Half (F L + F U - A * (L + U))) []; let (b, be) = mid_err bivl; let (B, Be) = (Num (float_of b), Num (float_of be)); divl ← approx p (Add (Half (F L - F U + A * (U - L))) Be) []; Some (affine_unop p a b (real_of_float (upper divl)) X) }" lemma min_range_antimono: assumes x: "x ∈ aform_err e X" assumes "l ≤ x" "x ≤ u" assumes "min_range_antimono p F DF l u X = Some Y" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes F: "⋀x. x ∈ {real_of_float l .. u} ⟹ interpret_floatarith (F (Num x)) [] = f x" assumes DF: "⋀x. x ∈ {real_of_float l .. u} ⟹ interpret_floatarith (DF (Num x)) [] = f' x" assumes f': "⋀x. x ∈ {real_of_float l .. u} ⟹ (f has_real_derivative f' x) (at x)" assumes f'_le: "⋀x. x ∈ {real_of_float l .. u} ⟹ f' x ≤ max (f' l) (f' u)" shows "f x ∈ aform_err e Y" proof - from assms obtain a b be aivl bivl divl where bivl: "(f l + f u - real_of_float a * (l + u)) / 2 ∈⇩r bivl" and Y: "Y = affine_unop p a b (real_of_float (upper divl)) X" and du: "(f l - f u + a * (u - l)) / 2 + be ∈⇩r divl" and a: "f' l ≤ a" "f' u ≤ a" and a_def: "a = upper aivl" and b_def: "b = (lower bivl + upper bivl) / 2" and be_def: "be = (upper bivl - lower bivl) / 2" by (auto simp: min_range_antimono_def Let_def bind_eq_Some_conv mid_err_def set_of_eq simp del: eq_divide_eq_numeral1 split: prod.splits if_splits dest!: approx_emptyD) have diff_le: "f' y ≤ real_of_float a" if "real_of_float l ≤ y" "y ≤ u" for y using f'_le[of y] that a by auto have le_be: "¦(f (l) + f (u) - a * (real_of_float l + u)) / 2 - b¦ ≤ be" using bivl unfolding b_def be_def by (auto simp: abs_real_def divide_simps set_of_eq) have "¦f x - (a * x + b)¦ ≤ upper divl" apply (rule min_range_coeffs_le) apply (rule ‹l ≤ x›) apply (rule ‹x ≤ u›) apply (rule f') apply assumption using diff_le apply force apply (rule order_trans[OF add_mono[OF order_refl]]) apply (rule le_be) using du bivl unfolding b_def[symmetric] be_def[symmetric] by (auto simp: set_of_eq) from affine_unop[where f=f and p = p, OF ‹x ∈ _› this e] have "f x ∈ aform_err e (affine_unop p (real_of_float a) b (upper divl) X)" by (auto simp: Y) then show ?thesis by (simp add: Y b_def) qed definition "cos_aform_err p X = do { X ← range_reduce_aform_err p X; let ivl = ivl_of_aform_err p X; let l = lower ivl; let u = upper ivl; let L = Num l; let U = Num u; if l ≥ 0 ∧ u ≤ lb_pi p then min_range_antimono p Cos (λx. (Minus (Sin x))) l u X else if l ≥ ub_pi p ∧ u ≤ 2 * lb_pi p then min_range_mono p Cos (λx. (Minus (Sin x))) l u X else do { Some (ivl_err (real_interval (cos_float_interval p ivl))) } }" lemma abs_half_enclosure: fixes r::real assumes "bl ≤ r" "r ≤ bu" shows "¦r - (bl + bu) / 2¦ ≤ (bu - bl) / 2" using assms by (auto simp: abs_real_def divide_simps) lemma cos_aform_err: assumes x: "x ∈ aform_err e X0" assumes "cos_aform_err p X0 = Some Y" assumes e: "e ∈ UNIV → {-1 .. 1}" shows "cos x ∈ aform_err e Y" proof - from assms obtain X ivl l u where X: "range_reduce_aform_err p X0 = Some X" and ivl_def: "ivl = ivl_of_aform_err p X" and l_def: "l = lower ivl" and u_def: "u = upper ivl" by (auto simp: cos_aform_err_def bind_eq_Some_conv) from range_reduce_aform_errE[OF e x X] obtain n where xn: "x + real_of_int n * (2 * pi) ∈ aform_err e X" by auto define xn where "xn = x + n * (2 * pi)" with xn have xn: "xn ∈ aform_err e X" by auto from ivl_of_aform_err[OF e xn, of p, folded ivl_def] have "xn ∈⇩r ivl" . then have lxn: "l ≤ xn" and uxn: "xn ≤ u" by (auto simp: l_def u_def set_of_eq) consider "l ≥ 0" "u ≤ lb_pi p" | "l < 0 ∨ u > lb_pi p" "l ≥ ub_pi p" "u ≤ 2 * lb_pi p" | "l < 0 ∨ u > lb_pi p" "l < ub_pi p ∨ u > 2 * lb_pi p" by arith then show ?thesis proof cases case 1 then have min_eq_Some: "min_range_antimono p Cos (λx. Minus (Sin x)) l u X = Some Y" and bounds: "0 ≤ l" "u ≤ (lb_pi p)" using assms(2) unfolding cos_aform_err_def X l_def u_def by (auto simp: X Let_def simp flip: l_def u_def ivl_def split: prod.splits) have bounds: "0 ≤ l" "u ≤ pi" using bounds pi_boundaries[of p] by auto have diff_le: "- sin y ≤ max (- sin (real_of_float l)) (- sin (real_of_float u))" if "real_of_float l ≤ y" "y ≤ real_of_float u" for y proof - consider "y ≤ pi / 2" | "y ≥ pi / 2" by arith then show ?thesis proof cases case 1 then have "- sin y ≤ - sin l" using that bounds by (auto intro!: sin_monotone_2pi_le) then show ?thesis by auto next case 2 then have "- sin y ≤ - sin u" using that bounds unfolding sin_minus_pi[symmetric] apply (intro sin_monotone_2pi_le) by (auto intro!: ) then show ?thesis by auto qed qed have "cos xn ∈ aform_err e Y" apply (rule min_range_antimono[OF xn lxn uxn min_eq_Some e, where f'="λx. - sin x"]) subgoal by simp subgoal by simp subgoal by (auto intro!: derivative_eq_intros) subgoal by (rule diff_le) auto done then show ?thesis unfolding xn_def by (simp add: ) next case 2 then have min_eq_Some: "min_range_mono p Cos (λx. Minus (Sin x)) l u X = Some Y" and bounds: "ub_pi p ≤ l" "u ≤ 2 * lb_pi p" using assms(2) unfolding cos_aform_err_def X by (auto simp: X Let_def simp flip: l_def u_def ivl_def split: prod.splits) have bounds: "pi ≤ l" "u ≤ 2 * pi" using bounds pi_boundaries[of p] by auto have diff_le: "min (- sin (real_of_float l)) (- sin (real_of_float u)) ≤ - sin y" if "real_of_float l ≤ y" "y ≤ real_of_float u" for y proof - consider "y ≤ 3 * pi / 2" | "y ≥ 3 * pi / 2" by arith then show ?thesis proof cases case 1 then have "- sin l ≤ - sin y" unfolding sin_minus_pi[symmetric] apply (intro sin_monotone_2pi_le) using that bounds by (auto) then show ?thesis by auto next case 2 then have "- sin u ≤ - sin y" unfolding sin_2pi_minus[symmetric] using that bounds apply (intro sin_monotone_2pi_le) by (auto intro!: ) then show ?thesis by auto qed qed have "cos xn ∈ aform_err e Y" apply (rule min_range_mono[OF xn lxn uxn min_eq_Some e, where f'="λx. - sin x"]) subgoal by simp subgoal by simp subgoal by (auto intro!: derivative_eq_intros) subgoal by (rule diff_le) auto done then show ?thesis unfolding xn_def by (simp add: ) next case 3 then obtain ivl' where "cos_float_interval p ivl = ivl'" "Y = ivl_err (real_interval ivl')" using assms(2) unfolding cos_aform_err_def X l_def u_def by (auto simp: X simp flip: l_def u_def ivl_def split: prod.splits) with cos_float_intervalI[OF ‹xn ∈⇩r ivl›, of p] show ?thesis by (auto simp: xn_def) qed qed definition "sqrt_aform_err p X = do { let ivl = ivl_of_aform_err p X; let l = lower ivl; let u = upper ivl; if 0 < l then min_range_mono p Sqrt (λx. Half (Inverse (Sqrt x))) l u X else Some (ivl_err (real_interval (sqrt_float_interval p ivl))) }" lemma sqrt_aform_err: assumes x: "x ∈ aform_err e X" assumes "sqrt_aform_err p X = Some Y" assumes e: "e ∈ UNIV → {-1 .. 1}" shows "sqrt x ∈ aform_err e Y" proof - obtain l u ivl where ivl_def: "ivl = ivl_of_aform_err p X" and l_def: "l = lower ivl" and u_def: "u = upper ivl" by auto from ivl_of_aform_err[OF e x, of p, folded ivl_def] have ivl: "x ∈⇩r ivl" . then have lx: "l ≤ x" and ux: "x ≤ u" by (auto simp flip: ivl_def simp: l_def u_def set_of_eq) consider "l > 0" | "l ≤ 0" by arith then show ?thesis proof cases case 1 then have min_eq_Some: "min_range_mono p Sqrt (λx. Half (Inverse (Sqrt x))) l u X = Some Y" and bounds: "0 < l" using assms(2) unfolding sqrt_aform_err_def by (auto simp: Let_def simp flip: l_def u_def ivl_def split: prod.splits) have "sqrt x ∈ aform_err e Y" apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'="λx. 1 / (2 * sqrt x)"]) subgoal by simp subgoal by (simp add: divide_simps) subgoal using bounds by (auto intro!: derivative_eq_intros simp: inverse_eq_divide) subgoal using ‹l > 0› by (auto simp: inverse_eq_divide min_def divide_simps) done then show ?thesis by (simp add: ) next case 2 then have "Y = ivl_err (real_interval (sqrt_float_interval p ivl))" using assms(2) unfolding sqrt_aform_err_def by (auto simp: Let_def simp flip: ivl_def l_def u_def split: prod.splits) with sqrt_float_intervalI[OF ivl] show ?thesis by (auto simp: set_of_eq) qed qed definition "ln_aform_err p X = do { let ivl = ivl_of_aform_err p X; let l = lower ivl; if 0 < l then min_range_mono p Ln inverse l (upper ivl) X else None }" lemma ln_aform_err: assumes x: "x ∈ aform_err e X" assumes "ln_aform_err p X = Some Y" assumes e: "e ∈ UNIV → {-1 .. 1}" shows "ln x ∈ aform_err e Y" proof - obtain ivl l u where l_def: "l = lower ivl" and u_def: "u = upper ivl" and ivl_def: "ivl = ivl_of_aform_err p X" by auto from ivl_of_aform_err[OF e x, of p, folded ivl_def] have "x ∈⇩r ivl" . then have lx: "l ≤ x" and ux: "x ≤ u" by (auto simp: set_of_eq l_def u_def) consider "l > 0" | "l ≤ 0" by arith then show ?thesis proof cases case 1 then have min_eq_Some: "min_range_mono p Ln inverse l u X = Some Y" and bounds: "0 < l" using assms(2) unfolding ln_aform_err_def by (auto simp: Let_def simp flip: ivl_def l_def u_def split: prod.splits if_splits) have "ln x ∈ aform_err e Y" apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'=inverse]) subgoal by simp subgoal by (simp add: divide_simps) subgoal using bounds by (auto intro!: derivative_eq_intros simp: inverse_eq_divide) subgoal using ‹l > 0› by (auto simp: inverse_eq_divide min_def divide_simps) done then show ?thesis by (simp add: ) next case 2 then show ?thesis using assms by (auto simp: ln_aform_err_def Let_def l_def ivl_def) qed qed definition "exp_aform_err p X = do { let ivl = ivl_of_aform_err p X; min_range_mono p Exp Exp (lower ivl) (upper ivl) X }" lemma exp_aform_err: assumes x: "x ∈ aform_err e X" assumes "exp_aform_err p X = Some Y" assumes e: "e ∈ UNIV → {-1 .. 1}" shows "exp x ∈ aform_err e Y" proof - obtain l u ivl where l_def: "l = lower ivl" and u_def: "u = upper ivl" and ivl_def: "ivl = ivl_of_aform_err p X" by auto from ivl_of_aform_err[OF e x, of p, folded ivl_def] have "x ∈⇩r ivl" . then have lx: "l ≤ x" and ux: "x ≤ u" by (auto simp: ivl_def l_def u_def set_of_eq) have min_eq_Some: "min_range_mono p Exp Exp l u X = Some Y" using assms(2) unfolding exp_aform_err_def by (auto simp: Let_def simp flip: ivl_def u_def l_def split: prod.splits if_splits) have "exp x ∈ aform_err e Y" apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'=exp]) subgoal by simp subgoal by (simp add: divide_simps) subgoal by (auto intro!: derivative_eq_intros simp: inverse_eq_divide) subgoal by (auto simp: inverse_eq_divide min_def divide_simps) done then show ?thesis by (simp add: ) qed definition "arctan_aform_err p X = do { let l = Inf_aform_err p X; let u = Sup_aform_err p X; min_range_mono p Arctan (λx. 1 / (Num 1 + x * x)) l u X }" lemma pos_add_nonneg_ne_zero: "a > 0 ⟹ b ≥ 0 ⟹ a + b ≠ 0" for a b::real by arith lemma arctan_aform_err: assumes x: "x ∈ aform_err e X" assumes "arctan_aform_err p X = Some Y" assumes e: "e ∈ UNIV → {-1 .. 1}" shows "arctan x ∈ aform_err e Y" proof - obtain l u where l: "l = Inf_aform_err p X" and u: "u = Sup_aform_err p X" by auto from x l u have lx: "l ≤ x" and ux: "x ≤ u" using Inf_Sup_aform_err[OF e, of X p] by auto have min_eq_Some: "min_range_mono p Arctan (λx. 1 / (Num 1 + x * x)) l u X = Some Y" using assms(2) unfolding arctan_aform_err_def l u by (auto simp: l[symmetric] u[symmetric] split: prod.splits if_splits) have "arctan x ∈ aform_err e Y" apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'="λx. inverse (1 + x⇧2)"]) subgoal by simp subgoal by (simp add: power2_eq_square inverse_eq_divide) subgoal by (auto intro!: derivative_eq_intros simp: inverse_eq_divide) subgoal for x apply (cases "x ≤ 0") subgoal apply (rule min.coboundedI1) apply (rule deriv_nonneg_imp_mono[of "real_of_float l" x]) by (auto intro!: derivative_eq_intros simp: mult_le_0_iff pos_add_nonneg_ne_zero) subgoal apply (rule min.coboundedI2) apply (rule le_imp_inverse_le) by (auto intro!: power_mono add_pos_nonneg) done done then show ?thesis by (simp add: ) qed subsection ‹Power, TODO: compare with Min-range approximation?!› definition "power_aform_err p (X::aform_err) n = (if n = 0 then ((1, zero_pdevs), 0) else if n = 1 then X else let x0 = float_of (fst (fst X)); xs = snd (fst X); xe = float_of (snd X); C = the (approx p (Num x0 ^⇩e n) []); (c, ce) = mid_err C; NX = the (approx p (Num (of_nat n) * (Num x0 ^⇩e (n - 1))) []); (nx, nxe) = mid_err NX; Y = scaleR_pdevs nx xs; (Y', Y_err) = trunc_bound_pdevs p Y; t = tdev' p xs; Ye = truncate_up p (nxe * t); err = the (approx p (Num (of_nat n) * Num xe * Abs (Num x0) ^⇩e (n - 1) + (Sum⇩e (λk. Num (of_nat (n choose k)) * Abs (Num x0) ^⇩e (n - k) * (Num xe + Num (float_of t)) ^⇩e k) [2..<Suc n])) []); ERR = upper err in ((c, Y'), sum_list' p [ce, Y_err, Ye, real_of_float ERR]))" lemma bounded_by_Nil: "bounded_by [] []" by (auto simp: bounded_by_def) lemma plain_floatarith_approx: assumes "plain_floatarith 0 f" shows "interpret_floatarith f [] ∈⇩r (the (approx p f []))" proof - from plain_floatarith_approx_not_None[OF assms(1), of Nil p] obtain ivl where "approx p f [] = Some ivl" by auto from this approx[OF bounded_by_Nil this] show ?thesis by auto qed lemma plain_floatarith_Sum⇩e: "plain_floatarith n (Sum⇩e f xs) ⟷ list_all (λi. plain_floatarith n (f i)) xs" by (induction xs) (auto simp: zero_floatarith_def plus_floatarith_def) lemma sum_list'_float[simp]: "sum_list' p xs ∈ float" by (induction xs rule: rev_induct) (auto simp: sum_list'_def eucl_truncate_up_real_def) lemma tdev'_float[simp]: "tdev' p xs ∈ float" by (auto simp: tdev'_def) lemma fixes x y::real assumes "abs (x - y) ≤ e" obtains err where "x = y + err" "abs err ≤ e" using assms apply atomize_elim apply (rule exI[where x="x - y"]) by (auto simp: abs_real_def) theorem power_aform_err: assumes "x ∈ aform_err e X" assumes floats[simp]: "fst (fst X) ∈ float" "snd X ∈ float" assumes e: "e ∈ UNIV → {-1 .. 1}" shows "x ^ n ∈ aform_err e (power_aform_err p X n)" proof - consider "n = 0" | "n = 1" | "n ≥ 2" by arith then show ?thesis proof cases case 1 then show ?thesis by (auto simp: aform_err_def power_aform_err_def aform_val_def) next case 2 then show ?thesis using assms by (auto simp: aform_err_def power_aform_err_def aform_val_def) next case n: 3 define x0 where "x0 = (fst (fst X))" define xs where "xs = snd (fst X)" define xe where "xe = (snd X)" have [simp]: "x0 ∈ float" "xe ∈ float" using assms by (auto simp: x0_def xe_def) define xe' where "xe' = x - aform_val e (x0, xs)" from aform_errE[OF assms(1)] have xe': "¦xe'¦ ≤ xe" by (auto simp: x0_def xs_def xe_def xe'_def) then have xe_nonneg: "0 ≤ xe" by (auto simp: ) define t where "t = tdev' p xs" have t: "tdev xs ≤ t" "t ∈ float" by (auto simp add: t_def tdev'_le) then have t_nonneg: "0 ≤ t" using tdev_nonneg[of xs] by arith note t_pdevs = abs_pdevs_val_le_tdev[OF e, THEN order_trans, OF t(1)] have rewr1: "{..n} = (insert 0 (insert 1 {2..n}))" using n by auto have "x = (pdevs_val e xs + xe') + x0" by (simp add: xe'_def aform_val_def) also have "… ^ n = x0 ^ n + n * x0 ^ (n - Suc 0) * pdevs_val e xs + (n * xe' * x0 ^ (n - Suc 0) + (∑k = 2..n. real (n choose k) * (pdevs_val e xs + xe') ^ k * x0 ^ (n - k)))" (is "_ = _ + ?err") apply (subst binomial_ring) unfolding rewr1 using n apply (simp add: algebra_simps) done also let ?ERR = "(Num (of_nat n) * Num (float_of xe) * Abs (Num (float_of x0)) ^⇩e (n - 1) + (Sum⇩e (λk. Num (of_nat (n choose k)) * Abs (Num (float_of x0)) ^⇩e (n - k) * (Num (float_of xe) + Num (float_of t)) ^⇩e k) [2..<Suc n]))" define err where "err = the (approx p ?ERR [])" define ERR where "ERR = upper err" have ERR: "abs ?err ≤ ERR" proof - have err_aerr: "abs (?err) ≤ n * xe * abs x0 ^ (n - Suc 0) + (∑k = 2..n. real (n choose k) * (t + xe) ^ k * abs x0 ^ (n - k))" (is "_ ≤ ?aerr") by (auto simp: abs_mult power_abs intro!: sum_mono mult_mono power_mono xe' mult_nonneg_nonneg zero_le_power t_nonneg xe_nonneg add_nonneg_nonneg sum_abs[THEN order_trans] abs_triangle_ineq[THEN order_trans] add_mono t_pdevs) also have rewr: "{2 .. n} = {2 ..<Suc n}" using n by (auto simp: ) have "plain_floatarith 0 ?ERR" by (auto simp add: zero_floatarith_def plain_floatarith_Sum⇩e times_floatarith_def plus_floatarith_def intro!: list_allI) from plain_floatarith_approx[OF this, of p] have "ERR ≥ ?aerr" using n by (auto simp: set_of_eq err_def ERR_def sum_list_distinct_conv_sum_set rewr t x0_def algebra_simps) finally show ?thesis . qed let ?x0n = "Num (float_of x0) ^⇩e n" define C where "C = the (approx p ?x0n [])" have "plain_floatarith 0 ?x0n" by simp from plain_floatarith_approx[OF this, of p] have C: "x0 ^ n ∈ {lower C .. upper C}" by (auto simp: C_def x0_def set_of_eq) define c where "c = fst (mid_err C)" define ce where "ce = snd (mid_err C)" define ce' where "ce' = x0 ^ n - c" have ce': "abs (ce') ≤ ce" using C by (auto simp: ce'_def c_def ce_def abs_diff_le_iff mid_err_def divide_simps) have "x0 ^ n = c + ce'" by (simp add: ce'_def) also let ?NX = "(Num (of_nat n) * (Num (float_of x0) ^⇩e (n - 1)))" define NX where "NX = the (approx p ?NX [])" have "plain_floatarith 0 ?NX" by (simp add: times_floatarith_def) from plain_floatarith_approx[OF this, of p] have NX: "n * x0 ^ (n - 1) ∈ {lower NX .. upper NX}" by (auto simp: NX_def x0_def set_of_eq) define nx where "nx = fst (mid_err NX)" define nxe where "nxe = snd (mid_err NX)" define nx' where "nx' = n * x0 ^ (n - 1) - nx" define Ye where "Ye = truncate_up p (nxe * t)" have Ye: "Ye ≥ nxe * t" by (auto simp: Ye_def truncate_up_le) have nx: "abs (nx') ≤ nxe" "0 ≤ nxe" using NX by (auto simp: nx_def nxe_def abs_diff_le_iff mid_err_def divide_simps nx'_def) have Ye: "abs (nx' * pdevs_val e xs) ≤ Ye" by (auto simp: Ye_def abs_mult intro!: truncate_up_le mult_mono nx t_pdevs) have "n * x0 ^ (n - Suc 0) = nx + nx'" by (simp add: nx'_def) also define Y where "Y = scaleR_pdevs nx xs" have Y: "pdevs_val e Y = nx * pdevs_val e xs" by (simp add: Y_def) have "(nx + nx') * pdevs_val e xs = pdevs_val e Y + nx' * pdevs_val e xs" unfolding Y by (simp add: algebra_simps) also define Y' where "Y' = fst (trunc_bound_pdevs p Y)" define Y_err where "Y_err = snd (trunc_bound_pdevs p Y)" have Y_err: "abs (- pdevs_val e (trunc_err_pdevs p Y)) ≤ Y_err" by (auto simp: Y_err_def trunc_bound_pdevs_def abs_pdevs_val_le_tdev' e) have "pdevs_val e Y = pdevs_val e Y' + - pdevs_val e (trunc_err_pdevs p Y)" by (simp add: Y'_def trunc_bound_pdevs_def pdevs_val_trunc_err_pdevs) finally have "¦x ^ n - aform_val e (c, Y') ¦ = ¦ce' + - pdevs_val e (trunc_err_pdevs p Y) + nx' * pdevs_val e xs + ?err¦" by (simp add: algebra_simps aform_val_def) also have "… ≤ ce + Y_err + Ye + ERR" by (intro ERR abs_triangle_ineq[THEN order_trans] add_mono ce' Ye Y_err) also have "… ≤ sum_list' p [ce, Y_err, Ye, real_of_float ERR]" by (auto intro!: sum_list'_sum_list_le) finally show ?thesis using n by (intro aform_errI) (auto simp: power_aform_err_def c_def Y'_def C_def Y_def ERR_def x0_def nx_def xs_def NX_def ce_def Y_err_def Ye_def xe_def nxe_def t_def Let_def split_beta' set_of_eq err_def) qed qed definition [code_abbrev]: "is_float r ⟷ r ∈ float" lemma [code]: "is_float (real_of_float f) = True" by (auto simp: is_float_def) definition "powr_aform_err p X A = ( if Inf_aform_err p X > 0 then do { L ← ln_aform_err p X; exp_aform_err p (mult_aform' p A L) } else approx_bin p (powr_float_interval p) X A)" lemma interval_extension_powr: "interval_extension2 (powr_float_interval p) (powr)" using powr_float_interval_eqI[of p] by (auto simp: interval_extension2_def) theorem powr_aform_err: assumes x: "x ∈ aform_err e X" assumes a: "a ∈ aform_err e A" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes Y: "powr_aform_err p X A = Some Y" shows "x powr a ∈ aform_err e Y" proof cases assume pos: "Inf_aform_err p X > 0" with Inf_Sup_aform_err[OF e, of X p] x have "x > 0" by auto then have "x powr a = exp (a * ln x)" by (simp add: powr_def) also from pos obtain L where L: "ln_aform_err p X = Some L" and E: "exp_aform_err p (mult_aform' p A L) = Some Y" using Y by (auto simp: bind_eq_Some_conv powr_aform_err_def) from ln_aform_err[OF x L e] have "ln x ∈ aform_err e L" . from mult_aform'E[OF e a this] have "a * ln x ∈ aform_err e (mult_aform' p A L)" . from exp_aform_err[OF this E e] have "exp (a * ln x) ∈ aform_err e Y" . finally show ?thesis . next from x a have xa: "x ∈ aform_err e (fst X, snd X)" "a ∈ aform_err e (fst A, snd A)" by simp_all assume "¬ Inf_aform_err p X > 0" then have "approx_bin p (powr_float_interval p) (fst X, snd X) (fst A, snd A) = Some Y" using Y by (auto simp: powr_aform_err_def) from approx_binE[OF interval_extension_powr xa this e] show "x powr a ∈ aform_err e Y" . qed fun approx_floatarith :: "nat ⇒ floatarith ⇒ aform_err list ⇒ (aform_err) option" where "approx_floatarith p (Add a b) vs = do { a1 ← approx_floatarith p a vs; a2 ← approx_floatarith p b vs; Some (add_aform' p a1 a2) }" | "approx_floatarith p (Mult a b) vs = do { a1 ← approx_floatarith p a vs; a2 ← approx_floatarith p b vs; Some (mult_aform' p a1 a2) }" | "approx_floatarith p (Inverse a) vs = do { a ← approx_floatarith p a vs; inverse_aform_err p a }" | "approx_floatarith p (Minus a) vs = map_option (apfst uminus_aform) (approx_floatarith p a vs)" | "approx_floatarith p (Num f) vs = Some (num_aform (real_of_float f), 0)" | "approx_floatarith p (Var i) vs = (if i < length vs then Some (vs ! i) else None)" | "approx_floatarith p (Abs a) vs = do { r ← approx_floatarith p a vs; let ivl = ivl_of_aform_err p r; let i = lower ivl; let s = upper ivl; if i > 0 then Some r else if s < 0 then Some (apfst uminus_aform r) else do { Some (ivl_err (real_interval (abs_interval ivl))) } }" | "approx_floatarith p (Min a b) vs = do { a1 ← approx_floatarith p a vs; a2 ← approx_floatarith p b vs; Some (min_aform_err p a1 a2) }" | "approx_floatarith p (Max a b) vs = do { a1 ← approx_floatarith p a vs; a2 ← approx_floatarith p b vs; Some (max_aform_err p a1 a2) }" | "approx_floatarith p (Floor a) vs = approx_un p (λivl. Some (floor_float_interval ivl)) (approx_floatarith p a vs)" | "approx_floatarith p (Cos a) vs = do { a ← approx_floatarith p a vs; cos_aform_err p a }" | "approx_floatarith p Pi vs = Some (ivl_err (real_interval (pi_float_interval p)))" | "approx_floatarith p (Sqrt a) vs = do { a ← approx_floatarith p a vs; sqrt_aform_err p a }" | "approx_floatarith p (Ln a) vs = do { a ← approx_floatarith p a vs; ln_aform_err p a }" | "approx_floatarith p (Arctan a) vs = do { a ← approx_floatarith p a vs; arctan_aform_err p a }" | "approx_floatarith p (Exp a) vs = do { a ← approx_floatarith p a vs; exp_aform_err p a }" | "approx_floatarith p (Power a n) vs = do { ((a, as), e) ← approx_floatarith p a vs; if is_float a ∧ is_float e then Some (power_aform_err p ((a, as), e) n) else None }" | "approx_floatarith p (Powr a b) vs = do { ae1 ← approx_floatarith p a vs; ae2 ← approx_floatarith p b vs; powr_aform_err p ae1 ae2 }" lemma uminus_aform_uminus_aform[simp]: "uminus_aform (uminus_aform z) = (z::'a::real_vector aform)" by (auto intro!: prod_eqI pdevs_eqI simp: uminus_aform_def) lemma degree_aform_inverse_aform': "degree_aform X ≤ n ⟹ degree_aform (fst (inverse_aform' p X)) ≤ n" unfolding inverse_aform'_def by (auto simp: Let_def trunc_bound_pdevs_def intro!: degree_pdev_upd_le degree_trunc_pdevs_le) lemma degree_aform_inverse_aform: assumes "inverse_aform p X = Some Y" assumes "degree_aform X ≤ n" shows "degree_aform (fst Y) ≤ n" using assms by (auto simp: inverse_aform_def Let_def degree_aform_inverse_aform' split: if_splits) lemma degree_aform_ivl_err[simp]: "degree_aform (fst (ivl_err a)) = 0" by (auto simp: ivl_err_def) lemma degree_aform_approx_bin: assumes "approx_bin p ivl X Y = Some Z" assumes "degree_aform (fst X) ≤ m" assumes "degree_aform (fst Y) ≤ m" shows "degree_aform (fst Z) ≤ m" using assms by (auto simp: approx_bin_def bind_eq_Some_conv Basis_list_real_def intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl]) lemma degree_aform_approx_un: assumes "approx_un p ivl X = Some Y" assumes "case X of None ⇒ True | Some X ⇒ degree_aform (fst X) ≤ d1" shows "degree_aform (fst Y) ≤ d1" using assms by (auto simp: approx_un_def bind_eq_Some_conv Basis_list_real_def intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl]) lemma degree_aform_num_aform[simp]: "degree_aform (num_aform x) = 0" by (auto simp: num_aform_def) lemma degree_max_aform: assumes "degree_aform_err x ≤ d" assumes "degree_aform_err y ≤ d" shows "degree_aform_err (max_aform_err p x y) ≤ d" using assms by (auto simp: max_aform_err_def Let_def Basis_list_real_def split: prod.splits intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl]) lemma degree_min_aform: assumes "degree_aform_err x ≤ d" assumes "degree_aform_err y ≤ d" shows "degree_aform_err ((min_aform_err p x y)) ≤ d" using assms by (auto simp: min_aform_err_def Let_def Basis_list_real_def split: prod.splits intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl]) lemma degree_aform_acc_err: "degree_aform (fst (acc_err p X e)) ≤ d" if "degree_aform (fst X) ≤ d" using that by (auto simp: acc_err_def) lemma degree_pdev_upd_degree: assumes "degree b ≤ Suc n" assumes "degree b ≤ Suc (degree_aform_err X)" assumes "degree_aform_err X ≤ n" shows "degree (pdev_upd b (degree_aform_err X) 0) ≤ n" using assms by (auto intro!: degree_le) lemma degree_aform_err_inverse_aform_err: assumes "inverse_aform_err p X = Some Y" assumes "degree_aform_err X ≤ n" shows "degree_aform_err Y ≤ n" using assms apply (auto simp: inverse_aform_err_def bind_eq_Some_conv aform_to_aform_err_def acc_err_def map_aform_err_def aform_err_to_aform_def intro!: degree_aform_acc_err) apply (rule degree_pdev_upd_degree) apply (auto dest!: degree_aform_inverse_aform) apply (meson degree_pdev_upd_le nat_le_linear not_less_eq_eq order_trans) apply (meson degree_pdev_upd_le nat_le_linear not_less_eq_eq order_trans) done lemma degree_aform_err_affine_unop: "degree_aform_err (affine_unop p a b d X) ≤ n" if "degree_aform_err X ≤ n" using that by (auto simp: affine_unop_def trunc_bound_pdevs_def degree_trunc_pdevs_le split: prod.splits) lemma degree_aform_err_min_range_mono: assumes "min_range_mono p F D l u X = Some Y" assumes "degree_aform_err X ≤ n" shows "degree_aform_err Y ≤ n" using assms by (auto simp: min_range_mono_def bind_eq_Some_conv aform_to_aform_err_def acc_err_def map_aform_err_def mid_err_def range_reduce_aform_err_def aform_err_to_aform_def Let_def split: if_splits prod.splits intro!: degree_aform_err_affine_unop) lemma degree_aform_err_min_range_antimono: assumes "min_range_antimono p F D l u X = Some Y" assumes "degree_aform_err X ≤ n" shows "degree_aform_err Y ≤ n" using assms by (auto simp: min_range_antimono_def bind_eq_Some_conv aform_to_aform_err_def acc_err_def map_aform_err_def mid_err_def range_reduce_aform_err_def aform_err_to_aform_def Let_def split: if_splits prod.splits intro!: degree_aform_err_affine_unop) lemma degree_aform_err_cos_aform_err: assumes "cos_aform_err p X = Some Y" assumes "degree_aform_err X ≤ n" shows "degree_aform_err Y ≤ n" using assms apply (auto simp: cos_aform_err_def bind_eq_Some_conv aform_to_aform_err_def acc_err_def map_aform_err_def mid_err_def range_reduce_aform_err_def aform_err_to_aform_def Let_def split: if_splits prod.splits intro!: degree_aform_err_affine_unop) apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le) apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_mono degree_aform_ivl_err zero_le) apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_mono degree_aform_ivl_err zero_le) apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le) apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le) apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le) done lemma degree_aform_err_sqrt_aform_err: assumes "sqrt_aform_err p X = Some Y" assumes "degree_aform_err X ≤ n" shows "degree_aform_err Y ≤ n" using assms apply (auto simp: sqrt_aform_err_def Let_def split: if_splits) apply (metis degree_aform_err_min_range_mono) done lemma degree_aform_err_arctan_aform_err: assumes "arctan_aform_err p X = Some Y" assumes "degree_aform_err X ≤ n" shows "degree_aform_err Y ≤ n" using assms apply (auto simp: arctan_aform_err_def bind_eq_Some_conv) apply (metis degree_aform_err_min_range_mono) done lemma degree_aform_err_exp_aform_err: assumes "exp_aform_err p X = Some Y" assumes "degree_aform_err X ≤ n" shows "degree_aform_err Y ≤ n" using assms apply (auto simp: exp_aform_err_def bind_eq_Some_conv) apply (metis degree_aform_err_min_range_mono) done lemma degree_aform_err_ln_aform_err: assumes "ln_aform_err p X = Some Y" assumes "degree_aform_err X ≤ n" shows "degree_aform_err Y ≤ n" using assms apply (auto simp: ln_aform_err_def Let_def split: if_splits) apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_mono degree_aform_ivl_err zero_le) done lemma degree_aform_err_power_aform_err: assumes "degree_aform_err X ≤ n" shows "degree_aform_err (power_aform_err p X m) ≤ n" using assms by (auto simp: power_aform_err_def Let_def trunc_bound_pdevs_def degree_trunc_pdevs_le split: if_splits prod.splits) lemma degree_aform_err_powr_aform_err: assumes "powr_aform_err p X Z = Some Y" assumes "degree_aform_err X ≤ n" assumes "degree_aform_err Z ≤ n" shows "degree_aform_err Y ≤ n" using assms apply (auto simp: powr_aform_err_def bind_eq_Some_conv degree_aform_mult_aform' dest!: degree_aform_err_ln_aform_err degree_aform_err_exp_aform_err split: if_splits) apply (metis degree_aform_mult_aform' fst_conv order_trans snd_conv) apply (rule degree_aform_approx_bin, assumption) apply auto done lemma approx_floatarith_degree: assumes "approx_floatarith p ra VS = Some X" assumes "⋀V. V ∈ set VS ⟹ degree_aform_err V ≤ d" shows "degree_aform_err X ≤ d" using assms proof (induction ra arbitrary: X) case (Add ra1 ra2) then show ?case by (auto simp: bind_eq_Some_conv intro!: degree_aform_err_add_aform' degree_aform_acc_err) next case (Minus ra) then show ?case by (auto simp: bind_eq_Some_conv) next case (Mult ra1 ra2) then show ?case by (auto simp: bind_eq_Some_conv intro!: degree_aform_mult_aform' degree_aform_acc_err) next case (Inverse ra) then show ?case by (auto simp: bind_eq_Some_conv intro: degree_aform_err_inverse_aform_err) next case (Cos ra) then show ?case by (auto simp: bind_eq_Some_conv intro: degree_aform_err_cos_aform_err) next case (Arctan ra) then show ?case by (auto simp: bind_eq_Some_conv intro: degree_aform_err_arctan_aform_err) next case (Abs ra) then show ?case by (auto simp: bind_eq_Some_conv Let_def Basis_list_real_def intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl] degree_aform_acc_err split: if_splits) next case (Max ra1 ra2) then show ?case by (auto simp: bind_eq_Some_conv intro!: degree_max_aform degree_aform_acc_err) next case (Min ra1 ra2) then show ?case by (auto simp: bind_eq_Some_conv intro!: degree_min_aform degree_aform_acc_err) next case Pi then show ?case by (auto simp: bind_eq_Some_conv Let_def Basis_list_real_def intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl] degree_aform_acc_err split: if_splits) next case (Sqrt ra) then show ?case by (auto simp: bind_eq_Some_conv intro: degree_aform_err_sqrt_aform_err) next case (Exp ra) then show ?case by (auto simp: bind_eq_Some_conv intro: degree_aform_err_exp_aform_err) next case (Powr ra1 ra2) then show ?case by (auto simp: bind_eq_Some_conv intro: degree_aform_err_powr_aform_err) next case (Ln ra) then show ?case by (auto simp: bind_eq_Some_conv intro: degree_aform_err_ln_aform_err) next case (Power ra x2a) then show ?case by (auto intro!: degree_aform_err_power_aform_err simp: bind_eq_Some_conv split: if_splits) next case (Floor ra) then show ?case apply - by (rule degree_aform_approx_un) (auto split: option.splits) next case (Var x) then show ?case by (auto simp: max_def split: if_splits) (use Var.prems(2) nat_le_linear nth_mem order_trans in blast)+ next case (Num x) then show ?case by auto qed definition affine_extension2 where "affine_extension2 fnctn_aff fnctn ⟷ ( ∀d a1 a2 X e2. fnctn_aff d a1 a2 = Some X ⟶ e2 ∈ UNIV → {- 1..1} ⟶ d ≥ degree_aform a1 ⟶ d ≥ degree_aform a2 ⟶ (∃e3 ∈ UNIV → {- 1..1}. (fnctn (aform_val e2 a1) (aform_val e2 a2) = aform_val e3 X ∧ (∀n. n < d ⟶ e3 n = e2 n) ∧ aform_val e2 a1 = aform_val e3 a1 ∧ aform_val e2 a2 = aform_val e3 a2)))" lemma affine_extension2E: assumes "affine_extension2 fnctn_aff fnctn" assumes "fnctn_aff d a1 a2 = Some X" "e ∈ UNIV → {- 1..1}" "d ≥ degree_aform a1" "d ≥ degree_aform a2" obtains e' where "e' ∈ UNIV → {- 1..1}" "fnctn (aform_val e a1) (aform_val e a2) = aform_val e' X" "⋀n. n < d ⟹ e' n = e n" "aform_val e a1 = aform_val e' a1" "aform_val e a2 = aform_val e' a2" using assms unfolding affine_extension2_def by metis lemma aform_err_uminus_aform: "- x ∈ aform_err e (uminus_aform X, ba)" if "e ∈ UNIV → {-1 .. 1}" "x ∈ aform_err e (X, ba)" using that by (auto simp: aform_err_def) definition "aforms_err e (xs::aform_err list) = listset (map (aform_err e) xs)" lemma aforms_err_Nil[simp]: "aforms_err e [] = {[]}" and aforms_err_Cons: "aforms_err e (x#xs) = set_Cons (aform_err e x) (aforms_err e xs)" by (auto simp: aforms_err_def) lemma in_set_ConsI: "a#b ∈ set_Cons A B" if "a ∈ A" and "b ∈ B" using that by (auto simp: set_Cons_def) lemma mem_aforms_err_Cons_iff[simp]: "x#xs ∈ aforms_err e (X#XS) ⟷ x ∈ aform_err e X ∧ xs ∈ aforms_err e XS" by (auto simp: aforms_err_Cons set_Cons_def) lemma mem_aforms_err_Cons_iff_Ex_conv: "x ∈ aforms_err e (X#XS) ⟷ (∃y ys. x = y#ys ∧ y ∈ aform_err e X ∧ ys ∈ aforms_err e XS)" by (auto simp: aforms_err_Cons set_Cons_def) lemma listset_Cons_mem_conv: "a # vs ∈ listset AVS ⟷ (∃A VS. AVS = A # VS ∧ a ∈ A ∧ vs ∈ listset VS)" by (induction AVS) (auto simp: set_Cons_def) lemma listset_Nil_mem_conv[simp]: "[] ∈ listset AVS ⟷ AVS = []" by (induction AVS) (auto simp: set_Cons_def) lemma listset_nthD: "vs ∈ listset VS ⟹ i < length vs ⟹ vs ! i ∈ VS ! i" by (induction vs arbitrary: VS i) (auto simp: nth_Cons listset_Cons_mem_conv split: nat.splits) lemma length_listsetD: "vs ∈ listset VS ⟹ length vs = length VS" by (induction vs arbitrary: VS) (auto simp: listset_Cons_mem_conv) lemma length_aforms_errD: "vs ∈ aforms_err e VS ⟹ length vs = length VS" by (auto simp: aforms_err_def length_listsetD) lemma nth_aforms_errI: "vs ! i ∈ aform_err e (VS ! i)" if "vs ∈ aforms_err e VS" "i < length vs" using that unfolding aforms_err_def apply - apply (frule listset_nthD, assumption) by (auto simp: aforms_err_def length_listsetD ) lemma eucl_truncate_down_float[simp]: "eucl_truncate_down p x ∈ float" by (auto simp: eucl_truncate_down_def) lemma eucl_truncate_up_float[simp]: "eucl_truncate_up p x ∈ float" by (auto simp: eucl_truncate_up_def) lemma trunc_bound_eucl_float[simp]: "fst (trunc_bound_eucl p x) ∈ float" "snd (trunc_bound_eucl p x) ∈ float" by (auto simp: trunc_bound_eucl_def Let_def) lemma add_aform'_float: "add_aform' p x y = ((a, b), ba) ⟹ a ∈ float" "add_aform' p x y = ((a, b), ba) ⟹ ba ∈ float" by (auto simp: add_aform'_def Let_def) lemma uminus_aform_float: "uminus_aform (aa, bb) = (a, b) ⟹ aa ∈ float ⟹ a ∈ float" by (auto simp: uminus_aform_def) lemma mult_aform'_float: "mult_aform' p x y = ((a, b), ba) ⟹ a ∈ float" "mult_aform' p x y = ((a, b), ba) ⟹ ba ∈ float" by (auto simp: mult_aform'_def Let_def split_beta') lemma inverse_aform'_float: "inverse_aform' p x = ((a, bb), baa) ⟹ a ∈ float" using [[linarith_split_limit=256]] by (auto simp: inverse_aform'_def Let_def) lemma inverse_aform_float: "inverse_aform p x = Some ((a, bb), baa) ⟹ a ∈ float" by (auto simp: inverse_aform_def Let_def apfst_def map_prod_def uminus_aform_def inverse_aform'_float split: if_splits prod.splits) lemma inverse_aform_err_float: "inverse_aform_err p x = Some ((a, b), ba) ⟹ a ∈ float" "inverse_aform_err p x = Some ((a, b), ba) ⟹ ba ∈ float" by (auto simp: inverse_aform_err_def map_aform_err_def acc_err_def bind_eq_Some_conv aform_err_to_aform_def aform_to_aform_err_def inverse_aform_float) lemma affine_unop_float: "affine_unop p asdf aaa bba h = ((a, b), ba) ⟹ a ∈ float" "affine_unop p asdf aaa bba h = ((a, b), ba) ⟹ ba ∈ float" by (auto simp: affine_unop_def trunc_bound_eucl_def Let_def split: prod.splits) lemma min_range_antimono_float: "min_range_antimono p f f' i g h = Some ((a, b), ba) ⟹ a ∈ float" "min_range_antimono p f f' i g h = Some ((a, b), ba) ⟹ ba ∈ float" by (auto simp: min_range_antimono_def Let_def bind_eq_Some_conv mid_err_def affine_unop_float split: prod.splits) lemma min_range_mono_float: "min_range_mono p f f' i g h = Some ((a, b), ba) ⟹ a ∈ float" "min_range_mono p f f' i g h = Some ((a, b), ba) ⟹ ba ∈ float" by (auto simp: min_range_mono_def Let_def bind_eq_Some_conv mid_err_def affine_unop_float split: prod.splits) lemma in_float_timesI: "a ∈ float" if "b = a * 2" "b ∈ float" proof - from that have "a = b / 2" by simp also have "… ∈ float" using that(2) by auto finally show ?thesis . qed lemma interval_extension_floor: "interval_extension1 (λivl. Some (floor_float_interval ivl)) floor" by (auto simp: interval_extension1_def floor_float_intervalI) lemma approx_floatarith_Elem: assumes "approx_floatarith p ra VS = Some X" assumes e: "e ∈ UNIV → {-1 .. 1}" assumes "vs ∈ aforms_err e VS" shows "interpret_floatarith ra vs ∈ aform_err e X" using assms(1) proof (induction ra arbitrary: X) case (Add ra1 ra2) then show ?case by (auto simp: bind_eq_Some_conv intro!: add_aform'[OF e]) next case (Minus ra) then show ?case by (auto intro!: aform_err_uminus_aform[OF e]) next case (Mult ra1 ra2) then show ?case by (auto simp: bind_eq_Some_conv intro!: mult_aform'E[OF e]) next case (Inverse ra) then show ?case by (auto simp: bind_eq_Some_conv intro!: inverse_aform_err[OF e]) next case (Cos ra) then show ?case by (auto simp: bind_eq_Some_conv intro!: cos_aform_err[OF _ _ e]) next case (Arctan ra) then show ?case by (auto simp: bind_eq_Some_conv intro!: arctan_aform_err[OF _ _ e]) next case (Abs fa) from Abs.prems obtain a where a: "approx_floatarith p fa VS = Some a" by (auto simp add: Let_def bind_eq_Some_conv) from Abs.IH[OF a] have mem: "interpret_floatarith fa vs ∈ aform_err e a" by auto then have mem': "-interpret_floatarith fa vs ∈ aform_err e (apfst uminus_aform a)" by (auto simp: aform_err_def) let ?i = "lower (ivl_of_aform_err p a)" let ?s = "upper (ivl_of_aform_err p a)" consider "?i > 0" | "?i ≤ 0" "?s < 0" | "?i ≤ 0" "?s ≥ 0" by arith then show ?case proof cases case hyps: 1 then show ?thesis using Abs.prems mem ivl_of_aform_err[OF e mem, of p] by (auto simp: a set_of_eq) next case hyps: 2 then show ?thesis using Abs.prems mem ivl_of_aform_err[OF e mem, of p] ivl_of_aform_err[OF e mem', of p] by (cases a) (auto simp: a abs_real_def set_of_eq intro!: aform_err_uminus_aform[OF e]) next case hyps: 3 then show ?thesis using Abs.prems mem ivl_of_aform_err[OF e mem, of p] by (auto simp: a abs_real_def max_def Let_def set_of_eq) qed next case (Max ra1 ra2) from Max.prems obtain a b where a: "approx_floatarith p ra1 VS = Some a" and b: "approx_floatarith p ra2 VS = Some b" by (auto simp add: Let_def bind_eq_Some_conv) from Max.IH(1)[OF a] Max.IH(2)[OF b] have mem: "interpret_floatarith ra1 vs ∈ aform_err e a" "interpret_floatarith ra2 vs ∈ aform_err e b" by auto let ?ia = "lower (ivl_of_aform_err p a)" let ?sa = "upper (ivl_of_aform_err p a)" let ?ib = "lower (ivl_of_aform_err p b)" let ?sb = "upper (ivl_of_aform_err p b)" consider "?sa < ?ib" | "?sa ≥ ?ib" "?sb < ?ia" | "?sa ≥ ?ib" "?sb ≥ ?ia" by arith then show ?case using Max.prems mem ivl_of_aform_err[OF e mem(1), of p] ivl_of_aform_err[OF e mem(2), of p] by cases (auto simp: a b max_def max_aform_err_def set_of_eq) next case (Min ra1 ra2) from Min.prems obtain a b where a: "approx_floatarith p ra1 VS = Some a" and b: "approx_floatarith p ra2 VS = Some b" by (auto simp add: Let_def bind_eq_Some_conv) from Min.IH(1)[OF a] Min.IH(2)[OF b] have mem: "interpret_floatarith ra1 vs ∈ aform_err e a" "interpret_floatarith ra2 vs ∈ aform_err e b" by auto let ?ia = "lower (ivl_of_aform_err p a)" let ?sa = "upper (ivl_of_aform_err p a)" let ?ib = "lower (ivl_of_aform_err p b)" let ?sb = "upper (ivl_of_aform_err p b)" consider "?sa < ?ib" | "?sa ≥ ?ib" "?sb < ?ia" | "?sa ≥ ?ib" "?sb ≥ ?ia" by arith then show ?case using Min.prems mem ivl_of_aform_err[OF e mem(1), of p] ivl_of_aform_err[OF e mem(2), of p] by cases (auto simp: a b min_def min_aform_err_def set_of_eq) next case Pi then show ?case using pi_float_interval by (auto simp: ) next case (Sqrt ra) then show ?case by (auto simp: bind_eq_Some_conv intro!: sqrt_aform_err[OF _ _ e]) next case (Exp ra) then show ?case by (auto simp: bind_eq_Some_conv intro!: exp_aform_err[OF _ _ e]) next case (Powr ra1 ra2) then show ?case by (auto simp: bind_eq_Some_conv intro!: powr_aform_err[OF _ _ e]) next case (Ln ra) then show ?case by (auto simp: bind_eq_Some_conv intro!: ln_aform_err[OF _ _ e]) next case (Power ra x2a) then show ?case by (auto simp: bind_eq_Some_conv is_float_def intro!: power_aform_err[OF _ _ _ e] split: if_splits) next case (Floor ra) then show ?case by (auto simp: bind_eq_Some_conv intro!: approx_unE[OF interval_extension_floor e] split: option.splits) next case (Var x) then show ?case using assms(3) apply - apply (frule length_aforms_errD) by (auto split: if_splits simp: aform_err_def dest!: nth_aforms_errI[where i=x]) next case (Num x) then show ?case by (auto split: if_splits simp: aform_err_def num_aform_def aform_val_def) qed primrec approx_floatariths_aformerr :: "nat ⇒ floatarith list ⇒ aform_err list ⇒ aform_err list option" where "approx_floatariths_aformerr _ [] _ = Some []" | "approx_floatariths_aformerr p (a#bs) vs = do { a ← approx_floatarith p a vs; r ← approx_floatariths_aformerr p bs vs; Some (a#r) }" lemma approx_floatariths_Elem: assumes "e ∈ UNIV → {-1 .. 1}" assumes "approx_floatariths_aformerr p ra VS = Some X" assumes "vs ∈ aforms_err e VS" shows "interpret_floatariths ra vs ∈ aforms_err e X" using assms(2) proof (induction ra arbitrary: X) case Nil then show ?case by simp next case (Cons ra ras) from Cons.prems obtain a r where a: "approx_floatarith p ra VS = Some a" and r: "approx_floatariths_aformerr p ras VS = Some r" and X: "X = a # r" by (auto simp: bind_eq_Some_conv) then show ?case using assms(1) by (auto simp: X Cons.IH intro!: approx_floatarith_Elem assms) qed lemma fold_max_mono: fixes x::"'a::linorder" shows "x ≤ y ⟹ fold max zs x ≤ fold max zs y" by (induct zs arbitrary: x y) (auto intro!: Cons simp: max_def) lemma fold_max_le_self: fixes y::"'a::linorder" shows "y ≤ fold max ys y" by (induct ys) (auto intro: order_trans[OF _ fold_max_mono]) lemma fold_max_le: fixes x::"'a::linorder" shows "x ∈ set xs ⟹ x ≤ fold max xs z" by (induct xs arbitrary: x z) (auto intro: order_trans[OF _ fold_max_le_self]) abbreviation "degree_aforms_err ≡ degrees o map (snd o fst)" definition "aforms_err_to_aforms d xs = (map (λ(d, x). aform_err_to_aform x d) (zip [d..<d + length xs] xs))" lemma aform_vals_empty[simp]: "aform_vals e' [] = []" by (auto simp: aform_vals_def) lemma aforms_err_to_aforms_Nil[simp]: "(aforms_err_to_aforms n []) = []" by (auto simp: aforms_err_to_aforms_def) lemma aforms_err_to_aforms_Cons[simp]: "aforms_err_to_aforms n (X # XS) = aform_err_to_aform X n # aforms_err_to_aforms (Suc n) XS" by (auto simp: aforms_err_to_aforms_def not_le nth_append nth_Cons intro!: nth_equalityI split: nat.splits) lemma degree_aform_err_to_aform_le: "degree_aform (aform_err_to_aform X n) ≤ max (degree_aform_err X) (Suc n)" by (auto simp: aform_err_to_aform_def intro!: degree_le) lemma less_degree_aform_aform_err_to_aformD: "i < degree_aform (aform_err_to_aform X n) ⟹ i < max (Suc n) (degree_aform_err X)" using degree_aform_err_to_aform_le[of X n] by auto lemma pdevs_domain_aform_err_to_aform: "pdevs_domain (snd (aform_err_to_aform X n)) = pdevs_domain (snd (fst X)) ∪ (if snd X = 0 then {} else {n})" if "n ≥ degree_aform_err X" using that by (auto simp: aform_err_to_aform_def split: if_splits) lemma length_aforms_err_to_aforms[simp]: "length (aforms_err_to_aforms i XS) = length XS" by (auto simp: aforms_err_to_aforms_def) lemma aforms_err_to_aforms_ex: assumes X: "x ∈ aforms_err e X" assumes deg: "degree_aforms_err X ≤ n" assumes e: "e ∈ UNIV → {-1 .. 1}" shows "∃e'∈ UNIV → {-1 .. 1}. x = aform_vals e' (aforms_err_to_aforms n X) ∧ (∀i < n. e' i = e i)" using X deg proof (induction X arbitrary: x n) case Nil then show ?case using e by (auto simp: o_def degrees_def intro!: bexI[where x="λi. e i"]) next case (Cons X XS) from Cons.prems obtain y ys where ys: "degree_aform_err X ≤ n" "degree_aforms_err XS ≤ n" "x = y # ys" "y ∈ aform_err e X" "ys ∈ aforms_err e XS" by (auto simp: mem_aforms_err_Cons_iff_Ex_conv degrees_def) then have "degree_aforms_err XS ≤ Suc n" by auto from Cons.IH[OF ys(5) this] obtain e' where e': "e'∈UNIV → {- 1..1}" "ys = aform_vals e' (aforms_err_to_aforms (Suc n) XS)" "(∀i<n. e' i = e i)" by auto from aform_err_to_aformE[OF ys(4,1)] obtain err where err: "y = aform_val (e(n := err)) (aform_err_to_aform X n)" "- 1 ≤ err" "err ≤ 1" by auto show ?case proof (safe intro!: bexI[where x="e'(n:=err)"], goal_cases) case 1 then show ?case unfolding ys e' err apply (auto simp: aform_vals_def aform_val_def simp del: pdevs_val_upd) apply (rule pdevs_val_degree_cong) apply simp subgoal using ys e' by (auto dest!: less_degree_aform_aform_err_to_aformD simp: max_def split: if_splits) subgoal premises prems for a b proof - have "pdevs_val (λa. if a = n then err else e' a) b = pdevs_val (e'(n:=err)) b" unfolding fun_upd_def by simp also have "… = pdevs_val e' b - e' n * pdevs_apply b n + err * pdevs_apply b n" by simp also from prems obtain i where i: "aforms_err_to_aforms (Suc n) XS ! i = (a, b)" "i < length (aforms_err_to_aforms (Suc n) XS)" by (auto simp: in_set_conv_nth ) { note i(1)[symmetric] also have "aforms_err_to_aforms (Suc n) XS ! i = aform_err_to_aform (XS ! i) (Suc n + i) " unfolding aforms_err_to_aforms_def using i by (simp del: upt_Suc) finally have "b = snd (aform_err_to_aform (XS ! i) (Suc n + i))" by (auto simp: prod_eq_iff) } note b = this have "degree_aform_err (XS ! i) ≤ n" using ys(2) i by (auto simp: degrees_def) then have "n ∉ pdevs_domain b" unfolding b apply (subst pdevs_domain_aform_err_to_aform) by (auto intro!: degree) then have "pdevs_apply b n = 0" by simp finally show ?thesis by simp qed done next case (2 i) then show ?case using e' by auto next case (3 i) then show ?case using e' err by auto qed qed lemma aforms_err_to_aformsE: assumes X: "x ∈ aforms_err e X" assumes deg: "degree_aforms_err X ≤ n" assumes e: "e ∈ UNIV → {-1 .. 1}" obtains e' where "x = aform_vals e' (aforms_err_to_aforms n X)" "e' ∈ UNIV → {-1 .. 1}" "⋀i. i < n ⟹ e' i = e i" using aforms_err_to_aforms_ex[OF X deg e] by blast definition "approx_floatariths p ea as = do { let da = (degree_aforms as); let aes = (map (λx. (x, 0)) as); rs ← approx_floatariths_aformerr p ea aes; let d = max da (degree_aforms_err (rs)); Some (aforms_err_to_aforms d rs) }" lemma listset_sings[simp]: "listset (map (λx. {f x}) as) = {map f as}" by (induction as) (auto simp: set_Cons_def) lemma approx_floatariths_outer: assumes "approx_floatariths p ea as = Some XS" assumes "vs ∈ Joints as" shows "(interpret_floatariths ea vs @ vs) ∈ Joints (XS @ as)" proof - from assms obtain da aes rs d where da: "da = degree_aforms as" and aes: "aes = (map (λx. (x, 0)) as)" and rs: "approx_floatariths_aformerr p ea aes = Some rs" and d: "d = max da (degree_aforms_err (rs))" and XS: "aforms_err_to_aforms d rs = XS" by (auto simp: approx_floatariths_def Let_def bind_eq_Some_conv) have abbd: "(a, b) ∈ set as ⟹ degree b ≤ degree_aforms as" for a b apply (rule degrees_leD[OF order_refl]) by force from da d have i_less: "(a, b) ∈ set as ⟹ i < degree b ⟹ i < min d da" for i a b by (auto dest!: abbd) have abbd: "(a, b) ∈ set as ⟹ degree b ≤ degree_aforms as" for a b apply (rule degrees_leD[OF order_refl]) by force from assms obtain e' where vs: "vs = (map (aform_val e') as)" and e': "e' ∈ UNIV → {-1 .. 1}" by (auto simp: Joints_def valuate_def) note vs also have vs_aes: "vs ∈ aforms_err e' aes" unfolding aes by (auto simp: vs aforms_err_def o_def aform_err_def) from approx_floatariths_Elem[OF e' rs this] have iars: "interpret_floatariths ea (map (aform_val e') as) ∈ aforms_err e' rs" by (auto simp: vs) have "degree_aforms_err rs ≤ d" by (auto simp: d da) from aforms_err_to_aformsE[OF iars this e'] obtain e where "interpret_floatariths ea (map (aform_val e') as) = aform_vals e XS" and e: "e ∈ UNIV → {- 1..1}" "⋀i. i < d ⟹ e i = e' i" by (auto simp: XS) note this (1) finally have "interpret_floatariths ea vs = aform_vals e XS" . moreover from e have e'_eq: "e' i = e i" if "i < min d da" for i using that by (auto simp: min_def split: if_splits) then have "vs = aform_vals e as" by (auto simp: vs aform_vals_def aform_val_def intro!: pdevs_val_degree_cong e'_eq i_less) ultimately show ?thesis using e(1) by (auto simp: Joints_def valuate_def aform_vals_def intro!: image_eqI[where x=e]) qed lemma length_eq_NilI: "length [] = length []" and length_eq_ConsI: "length xs = length ys ⟹ length (x#xs) = length (y#ys)" by auto subsection ‹Generic operations on Affine Forms in Euclidean Space› lemma pdevs_val_domain_cong: assumes "b = d" assumes "⋀i. i ∈ pdevs_domain b ⟹ a i = c i" shows "pdevs_val a b = pdevs_val c d" using assms by (auto simp: pdevs_val_pdevs_domain) lemma fresh_JointsI: assumes "xs ∈ Joints XS" assumes "list_all (λY. pdevs_domain (snd X) ∩ pdevs_domain (snd Y) = {}) XS" assumes "x ∈ Affine X" shows "x#xs ∈ Joints (X#XS)" using assms unfolding Joints_def Affine_def valuate_def proof safe fix e e'::"nat ⇒ real" assume H: "list_all (λY. pdevs_domain (snd X) ∩ pdevs_domain (snd Y) = {}) XS" "e ∈ UNIV → {- 1..1}" "e' ∈ UNIV → {- 1..1}" have "⋀a b i. ∀Y∈set XS. pdevs_domain (snd X) ∩ pdevs_domain (snd Y) = {} ⟹ pdevs_apply b i ≠ 0 ⟹ pdevs_apply (snd X) i ≠ 0 ⟹ (a, b) ∉ set XS" by (metis (poly_guards_query) IntI all_not_in_conv in_pdevs_domain snd_eqD) with H show "aform_val e' X # map (aform_val e) XS ∈ (λe. map (aform_val e) (X # XS)) ` (UNIV → {- 1..1})" by (intro image_eqI[where x = "λi. if i ∈ pdevs_domain (snd X) then e' i else e i"]) (auto simp: aform_val_def list_all_iff Pi_iff intro!: pdevs_val_domain_cong) qed primrec approx_slp::"nat ⇒ slp ⇒ aform_err list ⇒ aform_err list option" where "approx_slp p [] xs = Some xs" | "approx_slp p (ea # eas) xs = do { r ← approx_floatarith p ea xs; approx_slp p eas (r#xs) }" lemma Nil_mem_Joints[intro, simp]: "[] ∈ Joints []" by (force simp: Joints_def valuate_def) lemma map_nth_Joints: "xs ∈ Joints XS ⟹ (⋀i. i ∈ set is ⟹ i < length XS) ⟹ map (nth xs) is @ xs ∈ Joints (map (nth XS) is @ XS)" by (auto simp: Joints_def valuate_def) lemma map_nth_Joints': "xs ∈ Joints XS ⟹ (⋀i. i ∈ set is ⟹ i < length XS) ⟹ map (nth xs) is ∈ Joints (map (nth XS) is)" by (rule Joints_appendD2[OF map_nth_Joints]) auto lemma approx_slp_Elem: assumes e: "e ∈ UNIV → {-1 .. 1}" assumes "vs ∈ aforms_err e VS" assumes "approx_slp p ra VS = Some X" shows "interpret_slp ra vs ∈ aforms_err e X" using assms(2-) proof (induction ra arbitrary: X vs VS) case (Cons ra ras) from Cons.prems obtain a where a: "approx_floatarith p ra VS = Some a" and r: "approx_slp p ras (a # VS) = Some X" by (auto simp: bind_eq_Some_conv) from approx_floatarith_Elem[OF a e Cons.prems(1)] have "interpret_floatarith ra vs ∈ aform_err e a" by auto then have 1: "interpret_floatarith ra vs#vs ∈ aforms_err e (a#VS)" unfolding mem_aforms_err_Cons_iff using Cons.prems(1) by auto show ?case by (auto intro!: Cons.IH 1 r) qed auto definition "approx_slp_outer p n slp XS = do { let d = degree_aforms XS; let XSe = (map (λx. (x, 0)) XS); rs ← approx_slp p slp XSe; let rs' = take n rs; let d' = max d (degree_aforms_err rs'); Some (aforms_err_to_aforms d' rs') }" lemma take_in_listsetI: "xs ∈ listset XS ⟹ take n xs ∈ listset (take n XS)" by (induction XS arbitrary: xs n) (auto simp: take_Cons listset_Cons_mem_conv set_Cons_def split: nat.splits) lemma take_in_aforms_errI: "take n xs ∈ aforms_err e (take n XS)" if "xs ∈ aforms_err e XS" using that by (auto simp: aforms_err_def take_map[symmetric] intro!: take_in_listsetI) theorem approx_slp_outer: assumes "approx_slp_outer p n slp XS = Some RS" assumes slp: "slp = slp_of_fas fas" "n = length fas" assumes "xs ∈ Joints XS" shows "interpret_floatariths fas xs @ xs ∈ Joints (RS @ XS)" proof - from assms obtain d XSe rs rs' d' where d: "d = degree_aforms XS" and XSe: "XSe = (map (λx. (x, 0)) XS)" and rs: "approx_slp p (slp_of_fas fas) XSe = Some rs" and rs': "rs' = take (length fas) rs" and d': "d' = max d (degree_aforms_err rs')" and RS: "aforms_err_to_aforms d' rs' = RS" by (auto simp: approx_slp_outer_def Let_def bind_eq_Some_conv) have abbd: "(a, b) ∈ set XS ⟹ degree b ≤ degree_aforms XS" for a b apply (rule degrees_leD[OF order_refl]) by force from d' d have i_less: "(a, b) ∈ set XS ⟹ i < degree b ⟹ i < min d d'" for i a b by (auto dest!: abbd) from assms obtain e' where vs: "xs = (map (aform_val e') XS)" and e': "e' ∈ UNIV → {-1 .. 1}" by (auto simp: Joints_def valuate_def) from d have d: "V ∈ set XS ⟹ degree_aform V ≤ d" for V by (auto intro!: degrees_leD) have xs_XSe: "xs ∈ aforms_err e' XSe" by (auto simp: vs aforms_err_def XSe o_def aform_err_def) from approx_slp_Elem[OF e' xs_XSe rs] have aforms_err: "interpret_slp (slp_of_fas fas) xs ∈ aforms_err e' rs" . have "interpret_floatariths fas xs = take (length fas) (interpret_slp (slp_of_fas fas) xs)" using assms by (simp add: slp_of_fas) also from aforms_err have "take (length fas) (interpret_slp (slp_of_fas fas) xs) ∈ aforms_err e' rs'" unfolding rs' by (auto simp: take_map intro!: take_in_aforms_errI) finally have ier: "interpret_floatariths fas xs ∈ aforms_err e' rs'" . have "degree_aforms_err rs' ≤ d'" using d' by auto from aforms_err_to_aformsE[OF ier this e'] obtain e where "interpret_floatariths fas xs = aform_vals e RS" and e: "e ∈ UNIV → {- 1..1}" "⋀i. i < d' ⟹ e i = e' i" unfolding RS by (auto simp: ) moreover from e have e'_eq: "e' i = e i" if "i < min d d'" for i using that by (auto simp: min_def split: if_splits) then have "xs = aform_vals e XS" by (auto simp: vs aform_vals_def aform_val_def intro!: pdevs_val_degree_cong e'_eq i_less) ultimately show ?thesis using e(1) by (auto simp: Joints_def valuate_def aform_vals_def intro!: image_eqI[where x=e]) qed theorem approx_slp_outer_plain: assumes "approx_slp_outer p n slp XS = Some RS" assumes slp: "slp = slp_of_fas fas" "n = length fas" assumes "xs ∈ Joints XS" shows "interpret_floatariths fas xs ∈ Joints RS" proof - have "length fas = length RS" proof - have f1: "length xs = length XS" using Joints_imp_length_eq assms(4) by blast have "interpret_floatariths fas xs @ xs ∈ Joints (RS @ XS)" using approx_slp_outer assms(1) assms(2) assms(3) assms(4) by blast then show ?thesis using f1 Joints_imp_length_eq by fastforce qed with Joints_appendD2[OF approx_slp_outer[OF assms]] show ?thesis by simp qed end end
section ‹Counterclockwise› theory Counterclockwise imports "HOL-Analysis.Multivariate_Analysis" begin text ‹\label{sec:counterclockwise}› subsection ‹Auxiliary Lemmas› lemma convex3_alt: fixes x y z::"'a::real_vector" assumes "0 ≤ a" "0 ≤ b" "0 ≤ c" "a + b + c = 1" obtains u v where "a *⇩R x + b *⇩R y + c *⇩R z = x + u *⇩R (y - x) + v *⇩R (z - x)" and "0 ≤ u" "0 ≤ v" "u + v ≤ 1" proof - from convex_hull_3[of x y z] have "a *⇩R x + b *⇩R y + c *⇩R z ∈ convex hull {x, y, z}" using assms by auto also note convex_hull_3_alt finally obtain u v where "a *⇩R x + b *⇩R y + c *⇩R z = x + u *⇩R (y - x) + v *⇩R (z - x)" and uv: "0 ≤ u" "0 ≤ v" "u + v ≤ 1" by auto thus ?thesis .. qed lemma (in ordered_ab_group_add) add_nonpos_eq_0_iff: assumes x: "0 ≥ x" and y: "0 ≥ y" shows "x + y = 0 ⟷ x = 0 ∧ y = 0" proof - from add_nonneg_eq_0_iff[of "-x" "-y"] assms have "- (x + y) = 0 ⟷ - x = 0 ∧ - y = 0" by simp also have "(- (x + y) = 0) = (x + y = 0)" unfolding neg_equal_0_iff_equal .. finally show ?thesis by simp qed lemma sum_nonpos_eq_0_iff: fixes f :: "'a ⇒ 'b::ordered_ab_group_add" shows "⟦finite A; ∀x∈A. f x ≤ 0⟧ ⟹ sum f A = 0 ⟷ (∀x∈A. f x = 0)" by (induct set: finite) (simp_all add: add_nonpos_eq_0_iff sum_nonpos) lemma fold_if_in_set: "fold (λx m. if P x m then x else m) xs x ∈ set (x#xs)" by (induct xs arbitrary: x) auto subsection ‹Sort Elements of a List› locale linorder_list0 = fixes le::"'a ⇒ 'a ⇒ bool" begin definition "min_for a b = (if le a b then a else b)" lemma min_for_in[simp]: "x ∈ S ⟹ y ∈ S ⟹ min_for x y ∈ S" by (auto simp: min_for_def) lemma fold_min_eqI1: "fold min_for ys y ∉ set ys ⟹ fold min_for ys y = y" using fold_if_in_set[of _ ys y] by (auto simp: min_for_def[abs_def]) function selsort where "selsort [] = []" | "selsort (y#ys) = (let xm = fold min_for ys y; xs' = List.remove1 xm (y#ys) in (xm#selsort xs'))" by pat_completeness auto termination by (relation "Wellfounded.measure length") (auto simp: length_remove1 intro!: fold_min_eqI1 dest!: length_pos_if_in_set) lemma in_set_selsort_eq: "x ∈ set (selsort xs) ⟷ x ∈ (set xs)" by (induct rule: selsort.induct) (auto simp: Let_def intro!: fold_min_eqI1) lemma set_selsort[simp]: "set (selsort xs) = set xs" using in_set_selsort_eq by blast lemma length_selsort[simp]: "length (selsort xs) = length xs" proof (induct xs rule: selsort.induct) case (2 x xs) from 2[OF refl refl] show ?case unfolding selsort.simps by (auto simp: Let_def length_remove1 simp del: selsort.simps split: if_split_asm intro!: Suc_pred dest!: fold_min_eqI1) qed simp lemma distinct_selsort[simp]: "distinct (selsort xs) = distinct xs" by (auto intro!: card_distinct dest!: distinct_card) lemma selsort_eq_empty_iff[simp]: "selsort xs = [] ⟷ xs = []" by (cases xs) (auto simp: Let_def) inductive sortedP :: "'a list ⇒ bool" where Nil: "sortedP []" | Cons: "∀y∈set ys. le x y ⟹ sortedP ys ⟹ sortedP (x # ys)" inductive_cases sortedP_Nil: "sortedP []" and sortedP_Cons: "sortedP (x#xs)" inductive_simps sortedP_Nil_iff: "sortedP Nil" and sortedP_Cons_iff: "sortedP (Cons x xs)" lemma sortedP_append_iff: "sortedP (xs @ ys) = (sortedP xs & sortedP ys & (∀x ∈ set xs. ∀y ∈ set ys. le x y))" by (induct xs) (auto intro!: Nil Cons elim!: sortedP_Cons) lemma sortedP_appendI: "sortedP xs ⟹ sortedP ys ⟹ (⋀x y. x ∈ set xs ⟹ y ∈ set ys ⟹ le x y) ⟹ sortedP (xs @ ys)" by (induct xs) (auto intro!: Nil Cons elim!: sortedP_Cons) lemma sorted_nth_less: "sortedP xs ⟹ i < j ⟹ j < length xs ⟹ le (xs ! i) (xs ! j)" by (induct xs arbitrary: i j) (auto simp: nth_Cons split: nat.split elim!: sortedP_Cons) lemma sorted_butlastI[intro, simp]: "sortedP xs ⟹ sortedP (butlast xs)" by (induct xs) (auto simp: elim!: sortedP_Cons intro!: sortedP.Cons dest!: in_set_butlastD) lemma sortedP_right_of_append1: assumes "sortedP (zs@[z])" assumes "y ∈ set zs" shows "le y z" using assms by (induct zs arbitrary: y z) (auto elim!: sortedP_Cons) lemma sortedP_right_of_last: assumes "sortedP zs" assumes "y ∈ set zs" "y ≠ last zs" shows "le y (last zs)" using assms apply (intro sortedP_right_of_append1[of "butlast zs" "last zs" y]) subgoal by (metis append_is_Nil_conv list.distinct(1) snoc_eq_iff_butlast split_list) subgoal by (metis List.insert_def append_butlast_last_id insert_Nil list.distinct(1) rotate1.simps(2) set_ConsD set_rotate1) done lemma selsort_singleton_iff: "selsort xs = [x] ⟷ xs = [x]" by (induct xs) (auto simp: Let_def) lemma hd_last_sorted: assumes "sortedP xs" "length xs > 1" shows "le (hd xs) (last xs)" proof (cases xs) case (Cons y ys) note ys = this thus ?thesis using ys assms by (auto elim!: sortedP_Cons) qed (insert assms, simp) end lemma (in comm_monoid_add) sum_list_distinct_selsort: assumes "distinct xs" shows "sum_list (linorder_list0.selsort le xs) = sum_list xs" using assms apply (simp add: distinct_sum_list_conv_Sum linorder_list0.distinct_selsort) apply (rule sum.cong) subgoal by (simp add: linorder_list0.set_selsort) subgoal by simp done declare linorder_list0.sortedP_Nil_iff[code] linorder_list0.sortedP_Cons_iff[code] linorder_list0.selsort.simps[code] linorder_list0.min_for_def[code] locale linorder_list = linorder_list0 le for le::"'a::ab_group_add ⇒ _" + fixes S assumes order_refl: "a ∈ S ⟹ le a a" assumes trans': "a ∈ S ⟹ b ∈ S ⟹ c ∈ S ⟹ a ≠ b ⟹ b ≠ c ⟹ a ≠ c ⟹ le a b ⟹ le b c ⟹ le a c" assumes antisym: "a ∈ S ⟹ b ∈ S ⟹ le a b ⟹ le b a ⟹ a = b" assumes linear': "a ∈ S ⟹ b ∈ S ⟹ a ≠ b ⟹ le a b ∨ le b a" begin lemma trans: "a ∈ S ⟹ b ∈ S ⟹ c ∈ S ⟹ le a b ⟹ le b c ⟹ le a c" by (cases "a = b" "b = c" "a = c" rule: bool.exhaust[case_product bool.exhaust[case_product bool.exhaust]]) (auto simp: order_refl intro: trans') lemma linear: "a ∈ S ⟹ b ∈ S ⟹ le a b ∨ le b a" by (cases "a = b") (auto simp: linear' order_refl) lemma min_le1: "w ∈ S ⟹ y ∈ S ⟹ le (min_for w y) y" and min_le2: "w ∈ S ⟹ y ∈ S ⟹ le (min_for w y) w" using linear by (auto simp: min_for_def refl) lemma fold_min: assumes "set xs ⊆ S" shows "list_all (λy. le (fold min_for (tl xs) (hd xs)) y) xs" proof (cases xs) case (Cons y ys) hence subset: "set (y#ys) ⊆ S" using assms by auto show ?thesis unfolding Cons list.sel using subset proof (induct ys arbitrary: y) case (Cons z zs) hence IH: "⋀y. y ∈ S ⟹ list_all (le (fold min_for zs y)) (y # zs)" by simp let ?f = "fold min_for zs (min_for z y)" have "?f ∈ set ((min_for z y)#zs)" unfolding min_for_def[abs_def] by (rule fold_if_in_set) also have "… ⊆ S" using Cons.prems by auto finally have "?f ∈ S" . have "le ?f (min_for z y)" using IH[of "min_for z y"] Cons.prems by auto moreover have "le (min_for z y) y" "le (min_for z y) z" using Cons.prems by (auto intro!: min_le1 min_le2) ultimately have "le ?f y" "le ?f z" using Cons.prems ‹?f ∈ S› by (auto intro!: trans[of ?f "min_for z y"]) thus ?case using IH[of "min_for z y"] using Cons.prems by auto qed (simp add: order_refl) qed simp lemma sortedP_selsort: assumes "set xs ⊆ S" shows "sortedP (selsort xs)" using assms proof (induction xs rule: selsort.induct) case (2 z zs) from this fold_min[of "z#zs"] show ?case by (fastforce simp: list_all_iff Let_def simp del: remove1.simps intro: Cons intro!: 2(1)[OF refl refl] dest!: rev_subsetD[OF _ set_remove1_subset])+ qed (auto intro!: Nil) end subsection ‹Abstract CCW Systems› locale ccw_system0 = fixes ccw::"'a ⇒ 'a ⇒ 'a ⇒ bool" and S::"'a set" begin abbreviation "indelta t p q r ≡ ccw t q r ∧ ccw p t r ∧ ccw p q t" abbreviation "insquare p q r s ≡ ccw p q r ∧ ccw q r s ∧ ccw r s p ∧ ccw s p q" end abbreviation "distinct3 p q r ≡ ¬(p = q ∨ p = r ∨ q = r)" abbreviation "distinct4 p q r s ≡ ¬(p = q ∨ p = r ∨ p = s ∨ ¬ distinct3 q r s)" abbreviation "distinct5 p q r s t ≡ ¬(p = q ∨ p = r ∨ p = s ∨ p = t ∨ ¬ distinct4 q r s t)" abbreviation "in3 S p q r ≡ p ∈ S ∧ q ∈ S ∧ r ∈ S" abbreviation "in4 S p q r s ≡ in3 S p q r ∧ s ∈ S" abbreviation "in5 S p q r s t ≡ in4 S p q r s ∧ t ∈ S" locale ccw_system12 = ccw_system0 + assumes cyclic: "ccw p q r ⟹ ccw q r p" assumes ccw_antisym: "distinct3 p q r ⟹ in3 S p q r ⟹ ccw p q r ⟹ ¬ ccw p r q" locale ccw_system123 = ccw_system12 + assumes nondegenerate: "distinct3 p q r ⟹ in3 S p q r ⟹ ccw p q r ∨ ccw p r q" begin lemma not_ccw_eq: "distinct3 p q r ⟹ in3 S p q r ⟹ ¬ ccw p q r ⟷ ccw p r q" using ccw_antisym nondegenerate by blast end locale ccw_system4 = ccw_system123 + assumes interior: "distinct4 p q r t ⟹ in4 S p q r t ⟹ ccw t q r ⟹ ccw p t r ⟹ ccw p q t ⟹ ccw p q r" begin lemma interior': "distinct4 p q r t ⟹ in4 S p q r t ⟹ ccw p q t ⟹ ccw q r t ⟹ ccw r p t ⟹ ccw p q r" by (metis ccw_antisym cyclic interior nondegenerate) end locale ccw_system1235' = ccw_system123 + assumes dual_transitive: "distinct5 p q r s t ⟹ in5 S p q r s t ⟹ ccw s t p ⟹ ccw s t q ⟹ ccw s t r ⟹ ccw t p q ⟹ ccw t q r ⟹ ccw t p r" locale ccw_system1235 = ccw_system123 + assumes transitive: "distinct5 p q r s t ⟹ in5 S p q r s t ⟹ ccw t s p ⟹ ccw t s q ⟹ ccw t s r ⟹ ccw t p q ⟹ ccw t q r ⟹ ccw t p r" begin lemmas ccw_axioms = cyclic nondegenerate ccw_antisym transitive sublocale ccw_system1235' proof (unfold_locales, rule ccontr, goal_cases) case prems: (1 p q r s t) hence "ccw s p q ⟹ ccw s r p" by (metis ccw_axioms prems) moreover have "ccw s r p ⟹ ccw s q r" by (metis ccw_axioms prems) moreover have "ccw s q r ⟹ ccw s p q" by (metis ccw_axioms prems) ultimately have "ccw s p q ∧ ccw s r p ∧ ccw s q r ∨ ccw s q p ∧ ccw s p r ∧ ccw s r q" by (metis ccw_axioms prems) thus False by (metis ccw_axioms prems) qed end locale ccw_system = ccw_system1235 + ccw_system4 end
section ‹CCW Vector Space› theory Counterclockwise_Vector imports Counterclockwise begin locale ccw_vector_space = ccw_system12 ccw S for ccw::"'a::real_vector ⇒ 'a ⇒ 'a ⇒ bool" and S + assumes translate_plus[simp]: "ccw (a + x) (b + x) (c + x) ⟷ ccw a b c" assumes scaleR1_eq[simp]: "0 < e ⟹ ccw 0 (e*⇩Ra) b = ccw 0 a b" assumes uminus1[simp]: "ccw 0 (-a) b = ccw 0 b a" assumes add1: "ccw 0 a b ⟹ ccw 0 c b ⟹ ccw 0 (a + c) b" begin lemma translate_plus'[simp]: "ccw (x + a) (x + b) (x + c) ⟷ ccw a b c" by (auto simp: ac_simps) lemma uminus2[simp]: "ccw 0 a (- b) = ccw 0 b a" by (metis minus_minus uminus1) lemma uminus_all[simp]: "ccw (-a) (-b) (-c) ⟷ ccw a b c" proof - have "ccw (-a) (-b) (-c) ⟷ ccw 0 (- (b - a)) (- (c - a))" using translate_plus[of "-a" a "-b" "-c"] by simp also have "… ⟷ ccw 0 (b - a) (c - a)" by (simp del: minus_diff_eq) also have "… ⟷ ccw a b c" using translate_plus[of a "-a" b c] by simp finally show ?thesis . qed lemma translate_origin: "NO_MATCH 0 p ⟹ ccw p q r ⟷ ccw 0 (q - p) (r - p)" using translate_plus[of p "- p" q r] by simp lemma translate[simp]: "ccw a (a + b) (a + c) ⟷ ccw 0 b c" by (simp add: translate_origin) lemma translate_plus3: "ccw (a - x) (b - x) c ⟷ ccw a b (c + x)" using translate_plus[of a "-x" b "c + x"] by simp lemma renormalize: "ccw 0 (a - b) (c - a) ⟹ ccw b a c" by (metis diff_add_cancel diff_self cyclic minus_diff_eq translate_plus3 uminus1) lemma cyclicI: "ccw p q r ⟹ ccw q r p" by (metis cyclic) lemma scaleR2_eq[simp]: "0 < e ⟹ ccw 0 xr (e *⇩R P) ⟷ ccw 0 xr P" using scaleR1_eq[of e "-P" xr] by simp lemma scaleR1_nonzero_eq: "e ≠ 0 ⟹ ccw 0 (e *⇩R a) b = (if e > 0 then ccw 0 a b else ccw 0 b a)" proof cases assume "e < 0" define e' where "e' = - e" hence "e = -e'" "e' > 0" using ‹e < 0› by simp_all thus ?thesis by simp qed simp lemma neg_scaleR[simp]: "x < 0 ⟹ ccw 0 (x *⇩R b) c ⟷ ccw 0 c b" using scaleR1_nonzero_eq by auto lemma scaleR1: "0 < e ⟹ ccw 0 xr P ⟹ ccw 0 (e *⇩R xr) P" by simp lemma add3: "ccw 0 a b ∧ ccw 0 a c ⟹ ccw 0 a (b + c)" using add1[of "-b" a "-c"] uminus1[of "b + c" a] by simp lemma add3_self[simp]: "ccw 0 p (p + q) ⟷ ccw 0 p q" using translate[of "-p" p "p + q"] apply (simp add: cyclic) apply (metis cyclic uminus2) done lemma add2_self[simp]: "ccw 0 (p + q) p ⟷ ccw 0 q p" using translate[of "-p" "p + q" p] apply simp apply (metis cyclic uminus1) done lemma scale_add3[simp]: "ccw 0 a (x *⇩R a + b) ⟷ ccw 0 a b" proof - { assume "x = 0" hence ?thesis by simp } moreover { assume "x > 0" hence ?thesis using add3_self scaleR1_eq by blast } moreover { assume "x < 0" define x' where "x' = - x" hence "x = -x'" "x' > 0" using ‹x < 0› by simp_all hence "ccw 0 a (x *⇩R a + b) = ccw 0 (x' *⇩R a + - b) (x' *⇩R a)" by (subst uminus1[symmetric]) simp also have "… = ccw 0 (- b) a" unfolding add2_self by (simp add: ‹x' > 0›) also have "… = ccw 0 a b" by simp finally have ?thesis . } ultimately show ?thesis by arith qed lemma scale_add3'[simp]: "ccw 0 a (b + x *⇩R a) ⟷ ccw 0 a b" and scale_minus3[simp]: "ccw 0 a (x *⇩R a - b) ⟷ ccw 0 b a" and scale_minus3'[simp]: "ccw 0 a (b - x *⇩R a) ⟷ ccw 0 a b" using scale_add3[of a x b] scale_add3[of a "-x" b] scale_add3[of a x "-b"] by (simp_all add: ac_simps) lemma sum: assumes fin: "finite X" assumes ne: "X≠{}" assumes ncoll: "(⋀x. x ∈ X ⟹ ccw 0 a (f x))" shows "ccw 0 a (sum f X)" proof - from ne obtain x where "x ∈ X" "insert x X = X" by auto have "ccw 0 a (sum f (insert x X))" using fin ncoll proof (induction X) case empty thus ?case using ‹x ∈ X› ncoll by auto next case (insert y F) hence "ccw 0 a (sum f (insert y (insert x F)))" by (cases "y = x") (auto intro!: add3) thus ?case by (simp add: insert_commute) qed thus ?thesis using ‹insert x X = X› by simp qed lemma sum2: assumes fin: "finite X" assumes ne: "X≠{}" assumes ncoll: "(⋀x. x ∈ X ⟹ ccw 0 (f x) a)" shows "ccw 0 (sum f X) a" using sum[OF assms(1,2), of "-a" f] ncoll by simp lemma translate_minus[simp]: "ccw (x - a) (x - b) (x - c) = ccw (-a) (-b) (-c)" using translate_plus[of "-a" x "-b" "-c"] by simp end locale ccw_convex = ccw_system ccw S for ccw and S::"'a::real_vector set" + fixes oriented assumes convex2: "u ≥ 0 ⟹ v ≥ 0 ⟹ u + v = 1 ⟹ ccw a b c ⟹ ccw a b d ⟹ oriented a b ⟹ ccw a b (u *⇩R c + v *⇩R d)" begin lemma convex_hull: assumes [intro, simp]: "finite C" assumes ccw: "⋀c. c ∈ C ⟹ ccw a b c" assumes ch: "x ∈ convex hull C" assumes oriented: "oriented a b" shows "ccw a b x" proof - define D where "D = C" have D: "C ⊆ D" "⋀c. c ∈ D ⟹ ccw a b c" by (simp_all add: D_def ccw) show "ccw a b x" using ‹finite C› D ch proof (induct arbitrary: x) case empty thus ?case by simp next case (insert c C) hence "C ⊆ D" by simp { assume "C = {}" hence ?case using insert by simp } moreover { assume "C ≠ {}" from convex_hull_insert[OF this, of c] insert(6) obtain u v d where "u ≥ 0" "v ≥ 0" "d ∈ convex hull C" "u + v = 1" and x: "x = u *⇩R c + v *⇩R d" by blast have "ccw a b d" by (auto intro: insert.hyps(3)[OF ‹C ⊆ D›] insert.prems ‹d ∈ convex hull C›) from insert have "ccw a b c" by simp from convex2[OF ‹0 ≤ u› ‹0 ≤ v› ‹u + v = 1› ‹ccw a b c› ‹ccw a b d› ‹oriented a b›] have ?case by (simp add: x) } ultimately show ?case by blast qed qed end end
section ‹CCW for Nonaligned Points in the Plane› theory Counterclockwise_2D_Strict imports Counterclockwise_Vector Affine_Arithmetic_Auxiliarities begin text ‹\label{sec:counterclockwise2d}› subsection ‹Determinant› type_synonym point = "real*real" fun det3::"point ⇒ point ⇒ point ⇒ real" where "det3 (xp, yp) (xq, yq) (xr, yr) = xp * yq + yp * xr + xq * yr - yq * xr - yp * xq - xp * yr" lemma det3_def': "det3 p q r = fst p * snd q + snd p * fst r + fst q * snd r - snd q * fst r - snd p * fst q - fst p * snd r" by (cases p q r rule: prod.exhaust[case_product prod.exhaust[case_product prod.exhaust]]) auto lemma det3_eq_det: "det3 (xa, ya) (xb, yb) (xc, yc) = det (vector [vector [xa, ya, 1], vector [xb, yb, 1], vector [xc, yc, 1]]::real^3^3)" unfolding Determinants.det_def UNIV_3 by (auto simp: sum_over_permutations_insert vector_3 sign_swap_id permutation_swap_id sign_compose) declare det3.simps[simp del] lemma det3_self23[simp]: "det3 a b b = 0" and det3_self12[simp]: "det3 b b a = 0" by (auto simp: det3_def') lemma coll_ex_scaling: assumes "b ≠ c" assumes d: "det3 a b c = 0" shows "∃r. a = b + r *⇩R (c - b)" proof - from assms have "fst b ≠ fst c ∨ snd b ≠ snd c" by (auto simp: prod_eq_iff) thus ?thesis proof assume neq: "fst b ≠ fst c" with d have "snd a = ((fst a - fst b) * snd c + (fst c - fst a) * snd b) / (fst c - fst b)" by (auto simp: det3_def' field_simps) hence "snd a = ((fst a - fst b)/ (fst c - fst b)) * snd c + ((fst c - fst a)/ (fst c - fst b)) * snd b" by (simp add: add_divide_distrib) hence "snd a = snd b + (fst a - fst b) * snd c / (fst c - fst b) + ((fst c - fst a) - (fst c - fst b)) * snd b / (fst c - fst b)" using neq by (simp add: field_simps) hence "snd a = snd b + ((fst a - fst b) * snd c + (- fst a + fst b) * snd b) / (fst c - fst b)" unfolding add_divide_distrib by (simp add: algebra_simps) also have "(fst a - fst b) * snd c + (- fst a + fst b) * snd b = (fst a - fst b) * (snd c - snd b)" by (simp add: algebra_simps) finally have "snd a = snd b + (fst a - fst b) / (fst c - fst b) * (snd c - snd b)" by simp moreover hence "fst a = fst b + (fst a - fst b) / (fst c - fst b) * (fst c - fst b)" using neq by simp ultimately have "a = b + ((fst a - fst b) / (fst c - fst b)) *⇩R (c - b)" by (auto simp: prod_eq_iff) thus ?thesis by blast next assume neq: "snd b ≠ snd c" with d have "fst a = ((snd a - snd b) * fst c + (snd c - snd a) * fst b) / (snd c - snd b)" by (auto simp: det3_def' field_simps) hence "fst a = ((snd a - snd b)/ (snd c - snd b)) * fst c + ((snd c - snd a)/ (snd c - snd b)) * fst b" by (simp add: add_divide_distrib) hence "fst a = fst b + (snd a - snd b) * fst c / (snd c - snd b) + ((snd c - snd a) - (snd c - snd b)) * fst b / (snd c - snd b)" using neq by (simp add: field_simps) hence "fst a = fst b + ((snd a - snd b) * fst c + (- snd a + snd b) * fst b) / (snd c - snd b)" unfolding add_divide_distrib by (simp add: algebra_simps) also have "(snd a - snd b) * fst c + (- snd a + snd b) * fst b = (snd a - snd b) * (fst c - fst b)" by (simp add: algebra_simps) finally have "fst a = fst b + (snd a - snd b) / (snd c - snd b) * (fst c - fst b)" by simp moreover hence "snd a = snd b + (snd a - snd b) / (snd c - snd b) * (snd c - snd b)" using neq by simp ultimately have "a = b + ((snd a - snd b) / (snd c - snd b)) *⇩R (c - b)" by (auto simp: prod_eq_iff) thus ?thesis by blast qed qed lemma cramer: "¬det3 s t q = 0 ⟹ (det3 t p r) = ((det3 t q r) * (det3 s t p) + (det3 t p q) * (det3 s t r))/(det3 s t q)" by (auto simp: det3_def' field_simps) lemma convex_comb_dets: assumes "det3 p q r > 0" shows "s = (det3 s q r / det3 p q r) *⇩R p + (det3 p s r / det3 p q r) *⇩R q + (det3 p q s / det3 p q r) *⇩R r" (is "?lhs = ?rhs") proof - from assms have "det3 p q r *⇩R ?lhs = det3 p q r *⇩R ?rhs" by (simp add: field_simps prod_eq_iff scaleR_add_right) (simp add: algebra_simps det3_def') thus ?thesis using assms by simp qed lemma four_points_aligned: assumes c: "det3 t p q = 0" "det3 t q r = 0" assumes distinct: "distinct5 t s p q r" shows "det3 t r p = 0" "det3 p q r = 0" proof - from distinct have d: "p ≠ q" "q ≠ r" by (auto) from coll_ex_scaling[OF d(1) c(1)] obtain s1 where s1: "t = p + s1 *⇩R (q - p)" by auto from coll_ex_scaling[OF d(2) c(2)] obtain s2 where s2: "t = q + s2 *⇩R (r - q)" by auto from distinct s1 have ne: "1 - s1 ≠ 0" by auto from s1 s2 have "(1 - s1) *⇩R p = (1 - s1 - s2) *⇩R q + s2 *⇩R r" by (simp add: algebra_simps) hence "(1 - s1) *⇩R p /⇩R (1 - s1)= ((1 - s1 - s2) *⇩R q + s2 *⇩R r) /⇩R (1 - s1)" by simp with ne have p: "p = ((1 - s1 - s2) / (1 - s1)) *⇩R q + (s2 / (1 - s1)) *⇩R r" using ne by (simp add: prod_eq_iff inverse_eq_divide add_divide_distrib) define k1 where "k1 = (1 - s1 - s2) / (1 - s1)" define k2 where "k2 = s2 / (1 - s1)" have "det3 t r p = det3 0 (k1 *⇩R q + (k2 - 1) *⇩R r) (k1 *⇩R q + (k2 - 1) *⇩R r + (- s1 * (k1 - 1)) *⇩R q - (s1 * k2) *⇩R r)" unfolding s1 p k1_def[symmetric] k2_def[symmetric] by (simp add: algebra_simps det3_def') also have "- s1 * (k1 - 1) = s1 * k2" using ne by (auto simp: k1_def field_simps k2_def) also have "1 - k1 = k2" using ne by (auto simp: k2_def k1_def field_simps) have k21: "k2 - 1 = -k1" using ne by (auto simp: k2_def k1_def field_simps) finally have "det3 t r p = det3 0 (k1 *⇩R (q - r)) ((k1 + (s1 * k2)) *⇩R (q - r))" by (auto simp: algebra_simps) also have "… = 0" by (simp add: algebra_simps det3_def') finally show "det3 t r p = 0" . have "det3 p q r = det3 (k1 *⇩R q + k2 *⇩R r) q r" unfolding p k1_def[symmetric] k2_def[symmetric] .. also have "… = det3 0 (r - q) (k1 *⇩R q + (-k1) *⇩R r)" unfolding k21[symmetric] by (auto simp: algebra_simps det3_def') also have "… = det3 0 (r - q) (-k1 *⇩R (r - q))" by (auto simp: det3_def' algebra_simps) also have "… = 0" by (auto simp: det3_def') finally show "det3 p q r = 0" . qed lemma det_identity: "det3 t p q * det3 t s r + det3 t q r * det3 t s p + det3 t r p * det3 t s q = 0" by (auto simp: det3_def' algebra_simps) lemma det3_eq_zeroI: assumes "p = q + x *⇩R (t - q)" shows "det3 q t p = 0" unfolding assms by (auto simp: det3_def' algebra_simps) lemma det3_rotate: "det3 a b c = det3 c a b" by (auto simp: det3_def') lemma det3_switch: "det3 a b c = - det3 a c b" by (auto simp: det3_def') lemma det3_switch': "det3 a b c = - det3 b a c" by (auto simp: det3_def') lemma det3_pos_transitive_coll: "det3 t s p > 0 ⟹ det3 t s r ≥ 0 ⟹ det3 t p q ≥ 0 ⟹ det3 t q r > 0 ⟹ det3 t s q = 0 ⟹ det3 t p r > 0" using det_identity[of t p q s r] by (metis add.commute add_less_same_cancel1 det3_switch det3_switch' less_eq_real_def less_not_sym monoid_add_class.add.left_neutral mult_pos_pos mult_zero_left mult_zero_right) lemma det3_pos_transitive: "det3 t s p > 0 ⟹ det3 t s q ≥ 0 ⟹ det3 t s r ≥ 0 ⟹ det3 t p q ≥ 0 ⟹ det3 t q r > 0 ⟹ det3 t p r > 0" apply (cases "det3 t s q ≠ 0") using cramer[of q t s p r] apply (force simp: det3_rotate[of q t p] det3_rotate[of p q t] det3_switch[of t p s] det3_switch'[of q t r] det3_rotate[of q t s] det3_rotate[of s q t] intro!: divide_pos_pos add_nonneg_pos) apply (metis det3_pos_transitive_coll) done lemma det3_zero_translate_plus[simp]: "det3 (a + x) (b + x) (c + x) = 0 ⟷ det3 a b c = 0" by (auto simp: algebra_simps det3_def') lemma det3_zero_translate_plus'[simp]: "det3 (a) (a + b) (a + c) = 0 ⟷ det3 0 b c = 0" by (auto simp: algebra_simps det3_def') lemma det30_zero_scaleR1: "0 < e ⟹ det3 0 xr P = 0 ⟹ det3 0 (e *⇩R xr) P = 0" by (auto simp: zero_prod_def algebra_simps det3_def') lemma det3_same[simp]: "det3 a x x = 0" by (auto simp: det3_def') lemma det30_zero_scaleR2: "0 < e ⟹ det3 0 P xr = 0 ⟹ det3 0 P (e *⇩R xr) = 0" by (auto simp: zero_prod_def algebra_simps det3_def') lemma det3_eq_zero: "e ≠ 0 ⟹ det3 0 xr (e *⇩R Q) = 0 ⟷ det3 0 xr Q = 0" by (auto simp: det3_def') lemma det30_plus_scaled3[simp]: "det3 0 a (b + x *⇩R a) = 0 ⟷ det3 0 a b = 0" by (auto simp: det3_def' algebra_simps) lemma det30_plus_scaled2[simp]: shows "det3 0 (a + x *⇩R a) b = 0 ⟷ (if x = -1 then True else det3 0 a b = 0)" (is "?lhs = ?rhs") proof assume "det3 0 (a + x *⇩R a) b = 0" hence "fst a * snd b * (1 + x) = fst b * snd a * (1 + x)" by (simp add: algebra_simps det3_def') thus ?rhs by (auto simp add: det3_def') qed (auto simp: det3_def' algebra_simps split: if_split_asm) lemma det30_uminus2[simp]: "det3 0 (-a) (b) = 0 ⟷ det3 0 a b = 0" and det30_uminus3[simp]: "det3 0 a (-b) = 0 ⟷ det3 0 a b = 0" by (auto simp: det3_def' algebra_simps) lemma det30_minus_scaled3[simp]: "det3 0 a (b - x *⇩R a) = 0 ⟷ det3 0 a b = 0" using det30_plus_scaled3[of a b "-x"] by simp lemma det30_scaled_minus3[simp]: "det3 0 a (e *⇩R a - b) = 0 ⟷ det3 0 a b = 0" using det30_plus_scaled3[of a "-b" e] by (simp add: algebra_simps) lemma det30_minus_scaled2[simp]: "det3 0 (a - x *⇩R a) b = 0 ⟷ (if x = 1 then True else det3 0 a b = 0)" using det30_plus_scaled2[of a "-x" b] by simp lemma det3_nonneg_scaleR1: "0 < e ⟹ det3 0 xr P ≥ 0 ⟹ det3 0 (e*⇩Rxr) P ≥ 0" by (auto simp add: det3_def' algebra_simps) lemma det3_nonneg_scaleR1_eq: "0 < e ⟹ det3 0 (e*⇩Rxr) P ≥ 0 ⟷ det3 0 xr P ≥ 0" by (auto simp add: det3_def' algebra_simps) lemma det3_translate_origin: "NO_MATCH 0 p ⟹ det3 p q r = det3 0 (q - p) (r - p)" by (auto simp: det3_def' algebra_simps) lemma det3_nonneg_scaleR_segment2: assumes "det3 x y z ≥ 0" assumes "a > 0" shows "det3 x ((1 - a) *⇩R x + a *⇩R y) z ≥ 0" proof - from assms have "0 ≤ det3 0 (a *⇩R (y - x)) (z - x)" by (intro det3_nonneg_scaleR1) (simp_all add: det3_translate_origin) thus ?thesis by (simp add: algebra_simps det3_translate_origin) qed lemma det3_nonneg_scaleR_segment1: assumes "det3 x y z ≥ 0" assumes "0 ≤ a" "a < 1" shows "det3 ((1 - a) *⇩R x + a *⇩R y) y z ≥ 0" proof - from assms have "det3 0 ((1 - a) *⇩R (y - x)) (z - x + (- a) *⇩R (y - x)) ≥ 0" by (subst det3_nonneg_scaleR1_eq) (auto simp add: det3_def' algebra_simps) thus ?thesis by (auto simp: algebra_simps det3_translate_origin) qed subsection ‹Strict CCW Predicate› definition "ccw' p q r ⟷ 0 < det3 p q r" interpretation ccw': ccw_vector_space ccw' by unfold_locales (auto simp: ccw'_def det3_def' algebra_simps) interpretation ccw': linorder_list0 "ccw' x" for x . lemma ccw'_contra: "ccw' t r q ⟹ ccw' t q r = False" by (auto simp: ccw'_def det3_def' algebra_simps) lemma not_ccw'_eq: "¬ ccw' t p s ⟷ ccw' t s p ∨ det3 t s p = 0" by (auto simp: ccw'_def det3_def' algebra_simps) lemma neq_left_right_of: "ccw' a b c ⟹ ccw' a c d ⟹ b ≠ d" by (auto simp: ccw'_def det3_def' algebra_simps) lemma ccw'_subst_collinear: assumes "det3 t r s = 0" assumes "s ≠ t" assumes "ccw' t r p" shows "ccw' t s p ∨ ccw' t p s" proof cases assume "r ≠ s" from assms have "det3 r s t = 0" by (auto simp: algebra_simps det3_def') from coll_ex_scaling[OF assms(2) this] obtain x where s: "r = s + x *⇩R (t - s)" by auto from assms(3)[simplified ccw'_def s] have "0 < det3 0 (s + x *⇩R (t - s) - t) (p - t)" by (auto simp: algebra_simps det3_def') also have "s + x *⇩R (t - s) - t = (1 - x) *⇩R (s - t)" by (simp add: algebra_simps) finally have ccw': "ccw' 0 ((1 - x) *⇩R (s - t)) (p - t)" by (simp add: ccw'_def) hence "x ≠ 1" by (auto simp add: det3_def' ccw'_def) { assume "x < 1" hence ?thesis using ccw' by (auto simp: not_ccw'_eq ccw'.translate_origin) } moreover { assume "x > 1" hence ?thesis using ccw' by (auto simp: not_ccw'_eq ccw'.translate_origin) } ultimately show ?thesis using ‹x ≠ 1› by arith qed (insert assms, simp) lemma ccw'_sorted_scaleR: "ccw'.sortedP 0 xs ⟹ r > 0 ⟹ ccw'.sortedP 0 (map ((*⇩R) r) xs)" by (induct xs) (auto intro!: ccw'.sortedP.Cons elim!: ccw'.sortedP_Cons simp del: scaleR_Pair) subsection ‹Collinearity› abbreviation "coll a b c ≡ det3 a b c = 0" lemma coll_zero[intro, simp]: "coll 0 z 0" by (auto simp: det3_def') lemma coll_zero1[intro, simp]: "coll 0 0 z" by (auto simp: det3_def') lemma coll_self[intro, simp]: "coll 0 z z" by (auto simp: ) lemma ccw'_not_coll: "ccw' a b c ⟹ ¬coll a b c" "ccw' a b c ⟹ ¬coll a c b" "ccw' a b c ⟹ ¬coll b a c" "ccw' a b c ⟹ ¬coll b c a" "ccw' a b c ⟹ ¬coll c a b" "ccw' a b c ⟹ ¬coll c b a" by (auto simp: det3_def' ccw'_def algebra_simps) lemma coll_add: "coll 0 x y ⟹ coll 0 x z ⟹ coll 0 x (y + z)" by (auto simp: det3_def' algebra_simps) lemma coll_scaleR_left_eq[simp]: "coll 0 (r *⇩R x) y ⟷ r = 0 ∨ coll 0 x y" by (auto simp: det3_def' algebra_simps) lemma coll_scaleR_right_eq[simp]: "coll 0 y (r *⇩R x) ⟷ r = 0 ∨ coll 0 y x" by (auto simp: det3_def' algebra_simps) lemma coll_scaleR: "coll 0 x y ⟹ coll 0 (r *⇩R x) y" by (auto simp: det3_def' algebra_simps) lemma coll_sum_list: "(⋀y. y ∈ set ys ⟹ coll 0 x y) ⟹ coll 0 x (sum_list ys)" by (induct ys) (auto intro!: coll_add) lemma scaleR_left_normalize: fixes a ::real and b c::"'a::real_vector" shows "a *⇩R b = c ⟷ (if a = 0 then c = 0 else b = c /⇩R a)" by (auto simp: field_simps) lemma coll_scale_pair: "coll 0 (a, b) (c, d) ⟹ (a, b) ≠ 0 ⟹ (∃x. (c, d) = x *⇩R (a, b))" by (auto intro: exI[where x="c/a"] exI[where x="d/b"] simp: det3_def' field_simps prod_eq_iff) lemma coll_scale: "coll 0 r q ⟹ r ≠ 0 ⟹ (∃x. q = x *⇩R r)" using coll_scale_pair[of "fst r" "snd r" "fst q" "snd q"] by simp lemma coll_add_trans: assumes "coll 0 x (y + z)" assumes "coll 0 y z" assumes "x ≠ 0" assumes "y ≠ 0" assumes "z ≠ 0" assumes "y + z ≠ 0" shows "coll 0 x z" proof (cases "snd z = 0") case True hence "snd y = 0" using assms by (cases z) (auto simp add: zero_prod_def det3_def') with True assms have "snd x = 0" by (cases y, cases z) (auto simp add: zero_prod_def det3_def') from ‹snd x = 0› ‹snd y = 0› ‹snd z = 0› show ?thesis by (auto simp add: zero_prod_def det3_def') next case False note z = False hence "snd y ≠ 0" using assms by (cases y) (auto simp add: zero_prod_def det3_def') with False assms have "snd x ≠ 0" apply (cases x) apply (cases y) apply (cases z) apply (auto simp add: zero_prod_def det3_def') apply (metis mult.commute mult_eq_0_iff ring_class.ring_distribs(1)) done with False assms ‹snd y ≠ 0› have yz: "snd (y + z) ≠ 0" by (cases x; cases y; cases z) (auto simp add: det3_def' zero_prod_def) from coll_scale[OF assms(1) assms(3)] coll_scale[OF assms(2) assms(4)] obtain r s where rs: "y + z = r *⇩R x" "z = s *⇩R y" by auto with z have "s ≠ 0" by (cases x; cases y; cases z) (auto simp: zero_prod_def) with rs z yz have "r ≠ 0" by (cases x; cases y; cases z) (auto simp: zero_prod_def) from ‹s ≠ 0› rs have "y = r *⇩R x - z" "y = z /⇩R s" by (auto simp: inverse_eq_divide algebra_simps) hence "r *⇩R x - z = z /⇩R s" by simp hence "r *⇩R x = (1 + inverse s) *⇩R z" by (auto simp: inverse_eq_divide algebra_simps) hence "x = (inverse r * (1 + inverse s)) *⇩R z" using ‹r ≠ 0› ‹s ≠ 0› by (auto simp: field_simps scaleR_left_normalize) from this show ?thesis by (auto intro: coll_scaleR) qed lemma coll_commute: "coll 0 a b ⟷ coll 0 b a" by (metis det3_rotate det3_switch' diff_0 diff_self) lemma coll_add_cancel: "coll 0 a (a + b) ⟹ coll 0 a b" by (cases a, cases b) (auto simp: det3_def' algebra_simps) lemma coll_trans: "coll 0 a b ⟹ coll 0 a c ⟹ a ≠ 0 ⟹ coll 0 b c" by (metis coll_scale coll_scaleR) lemma sum_list_posI: fixes xs::"'a::ordered_comm_monoid_add list" shows "(⋀x. x ∈ set xs ⟹ x > 0) ⟹ xs ≠ [] ⟹ sum_list xs > 0" proof (induct xs) case (Cons x xs) thus ?case by (cases "xs = []") (auto intro!: add_pos_pos) qed simp lemma nonzero_fstI[intro, simp]: "fst x ≠ 0 ⟹ x ≠ 0" and nonzero_sndI[intro, simp]: "snd x ≠ 0 ⟹ x ≠ 0" by auto lemma coll_sum_list_trans: "xs ≠ [] ⟹ coll 0 a (sum_list xs) ⟹ (⋀x. x ∈ set xs ⟹ coll 0 x y) ⟹ (⋀x. x ∈ set xs ⟹ coll 0 x (sum_list xs)) ⟹ (⋀x. x ∈ set xs ⟹ snd x > 0) ⟹ a ≠ 0 ⟹ coll 0 a y" proof (induct xs rule: list_nonempty_induct) case (single x) from single(1) single(2)[of x] single(4)[of x] have "coll 0 x a" "coll 0 x y" "x ≠ 0" by (auto simp: coll_commute) thus ?case by (rule coll_trans) next case (cons x xs) from cons(5)[of x] ‹a ≠ 0› cons(6)[of x] have *: "coll 0 x (sum_list xs)" "a ≠ 0" "x ≠ 0" by (force simp add: coll_add_cancel)+ have "0 < snd (sum_list (x#xs))" unfolding snd_sum_list by (rule sum_list_posI) (auto intro!: add_pos_pos cons simp: snd_sum_list) hence "x + sum_list xs ≠ 0" by simp from coll_add_trans[OF cons(3)[simplified] * _ this] have cH: "coll 0 a (sum_list xs)" by (cases "sum_list xs = 0") auto from cons(4) have cy: "(⋀x. x ∈ set xs ⟹ coll 0 x y)" by simp { fix y assume "y ∈ set xs" hence "snd (sum_list xs) > 0" unfolding snd_sum_list by (intro sum_list_posI) (auto intro!: add_pos_pos cons simp: snd_sum_list) hence "sum_list xs ≠ 0" by simp from cons(5)[of x] have "coll 0 x (sum_list xs)" by (simp add: coll_add_cancel) from cons(5)[of y] have "coll 0 y (sum_list xs)" using ‹y ∈ set xs› cons(6)[of y] ‹x + sum_list xs ≠ 0› apply (cases "y = x") subgoal by (force simp add: coll_add_cancel) subgoal by (force simp: dest!: coll_add_trans[OF _ *(1) _ *(3)]) done } note cl = this show ?case by (rule cons(2)[OF cH cy cl cons(6) ‹a ≠ 0›]) auto qed lemma sum_list_coll_ex_scale: assumes coll: "⋀x. x ∈ set xs ⟹ coll 0 z x" assumes nz: "z ≠ 0" shows "∃r. sum_list xs = r *⇩R z" proof - { fix i assume i: "i < length xs" hence nth: "xs ! i ∈ set xs" by simp note coll_scale[OF coll[OF nth] ‹z ≠ 0›] } then obtain r where r: "⋀i. i < length xs ⟹ r i *⇩R z = xs ! i" by metis have "xs = map ((!) xs) [0..<length xs]" by (simp add: map_nth) also have "… = map (λi. r i *⇩R z) [0..<length xs]" by (auto simp: r) also have "sum_list … = (∑i←[0..<length xs]. r i) *⇩R z" by (simp add: sum_list_sum_nth scaleR_sum_left) finally show ?thesis .. qed lemma sum_list_filter_coll_ex_scale: "z ≠ 0 ⟹ ∃r. sum_list (filter (coll 0 z) zs) = r *⇩R z" by (rule sum_list_coll_ex_scale) simp end
theory Polygon imports Counterclockwise_2D_Strict begin subsection ‹Polygonal chains› definition "polychain xs = (∀i. Suc i<length xs ⟶ snd (xs ! i) = (fst (xs ! Suc i)))" lemma polychainI: assumes "⋀i. Suc i < length xs ⟹ snd (xs ! i) = fst (xs ! Suc i)" shows "polychain xs" by (auto intro!: assms simp: polychain_def) lemma polychain_Nil[simp]: "polychain [] = True" and polychain_singleton[simp]: "polychain [x] = True" by (auto simp: polychain_def) lemma polychain_Cons: "polychain (y # ys) = (if ys = [] then True else snd y = fst (ys ! 0) ∧ polychain ys)" by (auto simp: polychain_def nth_Cons split: nat.split) lemma polychain_appendI: "polychain xs ⟹ polychain ys ⟹ (xs ≠ [] ⟹ ys ≠ [] ⟹ snd (last xs) = fst (hd ys)) ⟹ polychain (xs @ ys)" by (induct xs arbitrary: ys) (auto simp add: polychain_Cons nth_append hd_conv_nth split: if_split_asm) fun pairself where "pairself f (x, y) = (f x, f y)" lemma pairself_apply: "pairself f x = (f (fst x), f (snd x))" by (cases x, simp) lemma polychain_map_pairself: "polychain xs ⟹ polychain (map (pairself f) xs)" by (auto simp: polychain_def pairself_apply) definition "convex_polychain xs ⟷ (polychain xs ∧ (∀i. Suc i < length xs ⟶ det3 (fst (xs ! i)) (snd (xs ! i)) (snd (xs ! Suc i)) > 0))" lemma convex_polychain_Cons2[simp]: "convex_polychain (x#y#zs) ⟷ snd x = fst y ∧ det3 (fst x) (fst y) (snd y) > 0 ∧ convex_polychain (y#zs)" by (auto simp add: convex_polychain_def polychain_def nth_Cons split: nat.split) lemma convex_polychain_ConsD: assumes "convex_polychain (x#xs)" shows "convex_polychain xs" using assms by (auto simp: convex_polychain_def polychain_def nth_Cons split: nat.split) definition "convex_polygon xs ⟷ (convex_polychain xs ∧ (xs ≠ [] ⟶ fst (hd xs) = snd (last xs)))" lemma convex_polychain_Nil[simp]: "convex_polychain [] = True" and convex_polychain_Cons[simp]: "convex_polychain [x] = True" by (auto simp: convex_polychain_def) lemma convex_polygon_Cons2[simp]: "convex_polygon (x#y#zs) ⟷ fst x = snd (last (y#zs)) ∧ convex_polychain (x#y#zs)" by (auto simp: convex_polygon_def convex_polychain_def polychain_def nth_Cons) lemma polychain_append_connected: "polychain (xs @ ys) ⟹ xs ≠ [] ⟹ ys ≠ [] ⟹ fst (hd ys) = snd (last xs)" by (auto simp: convex_polychain_def nth_append not_less polychain_def last_conv_nth hd_conv_nth dest!: spec[where x = "length xs - 1"]) lemma convex_polychain_appendI: assumes cxs: "convex_polychain xs" assumes cys: "convex_polychain ys" assumes pxy: "polychain (xs @ ys)" assumes "xs ≠ [] ⟹ ys ≠ [] ⟹ det3 (fst (last xs)) (snd (last xs)) (snd (hd ys)) > 0" shows "convex_polychain (xs @ ys)" proof - { fix i assume "i < length xs" "length xs ≤ Suc i" "Suc i < length xs + length ys" hence "xs ≠ []" "ys ≠ []" "i = length xs - 1" by auto } thus ?thesis using assms by (auto simp: hd_conv_nth convex_polychain_def nth_append Suc_diff_le last_conv_nth ) qed lemma convex_polychainI: assumes "polychain xs" assumes "⋀i. Suc i < length xs ⟹ det3 (fst (xs ! i)) (snd (xs ! i)) (snd (xs ! Suc i)) > 0" shows "convex_polychain xs" by (auto intro!: assms simp: convex_polychain_def ccw'_def) lemma convex_polygon_skip: assumes "convex_polygon (x # y # z # w # ws)" assumes "ccw'.sortedP (fst x) (map snd (butlast (x # y # z # w # ws)))" shows "convex_polygon ((fst x, snd y) # z # w # ws)" using assms by (auto elim!: ccw'.sortedP_Cons simp: ccw'_def[symmetric]) primrec polychain_of::"'a::ab_group_add ⇒ 'a list ⇒ ('a*'a) list" where "polychain_of xc [] = []" | "polychain_of xc (xm#xs) = (xc, xc + xm)#polychain_of (xc + xm) xs" lemma in_set_polychain_ofD: "ab ∈ set (polychain_of x xs) ⟹ (snd ab - fst ab) ∈ set xs" by (induct xs arbitrary: x) auto lemma fst_polychain_of_nth_0[simp]: "xs ≠ [] ⟹ fst ((polychain_of p xs) ! 0) = p" by (cases xs) (auto simp: Let_def) lemma fst_hd_polychain_of: "xs ≠ [] ⟹ fst (hd (polychain_of x xs)) = x" by (cases xs) (auto simp: ) lemma length_polychain_of_eq[simp]: shows "length (polychain_of p qs) = length qs" by (induct qs arbitrary: p) simp_all lemma polychain_of_subsequent_eq: assumes "Suc i < length qs" shows "snd (polychain_of p qs ! i) = fst (polychain_of p qs ! Suc i)" using assms by (induct qs arbitrary: p i) (auto simp add: nth_Cons split: nat.split) lemma polychain_of_eq_empty_iff[simp]: "polychain_of p xs = [] ⟷ xs = []" by (cases xs) (auto simp: Let_def) lemma in_set_polychain_of_imp_sum_list: assumes "z ∈ set (polychain_of Pc Ps)" obtains d where "z = (Pc + sum_list (take d Ps), Pc + sum_list (take (Suc d) Ps))" using assms apply atomize_elim proof (induction Ps arbitrary: Pc z) case Nil thus ?case by simp next case (Cons P Ps) hence "z = (Pc, Pc + P) ∨ z ∈ set (polychain_of (Pc + P) Ps)" by auto thus ?case proof assume "z ∈ set ((polychain_of (Pc + P) Ps))" from Cons.IH[OF this] obtain d where "z = (Pc + P + sum_list (take d Ps), Pc + P + sum_list (take (Suc d) Ps))" by auto thus ?case by (auto intro!: exI[where x="Suc d"]) qed (auto intro!: exI[where x=0]) qed lemma last_polychain_of: "length xs > 0 ⟹ snd (last (polychain_of p xs)) = p + sum_list xs" by (induct xs arbitrary: p) simp_all lemma polychain_of_singleton_iff: "polychain_of p xs = [a] ⟷ fst a = p ∧ xs = [(snd a - p)]" by (induct xs) auto lemma polychain_of_add: "polychain_of (x + y) xs = map (((+) (y, y))) (polychain_of x xs)" by (induct xs arbitrary: x y) (auto simp: algebra_simps) subsection ‹Dirvec: Inverse of Polychain› primrec dirvec where "dirvec (x, y) = (y - x)" lemma dirvec_minus: "dirvec x = snd x - fst x" by (cases x) simp lemma dirvec_nth_polychain_of: "n < length xs ⟹ dirvec ((polychain_of p xs) ! n ) = (xs ! n)" by (induct xs arbitrary: p n) (auto simp: nth_Cons split: nat.split) lemma dirvec_hd_polychain_of: "xs ≠ [] ⟹ dirvec (hd (polychain_of p xs)) = (hd xs)" by (simp add: hd_conv_nth dirvec_nth_polychain_of) lemma dirvec_last_polychain_of: "xs ≠ [] ⟹ dirvec (last (polychain_of p xs)) = (last xs)" by (simp add: last_conv_nth dirvec_nth_polychain_of) lemma map_dirvec_polychain_of[simp]: "map dirvec (polychain_of x xs) = xs" by (induct xs arbitrary: x) simp_all subsection ‹Polychain of Sorted (@{term polychain_of}, @{term ccw'.sortedP})› lemma ccw'_sortedP_translateD: "linorder_list0.sortedP (ccw' x0) (map ((+) x ∘ g) xs) ⟹ linorder_list0.sortedP (ccw' (x0 - x)) (map g xs)" proof (induct xs arbitrary: x0 x) case Nil thus ?case by (auto simp: linorder_list0.sortedP.Nil) next case (Cons a xs x0 x) hence "∀y∈set xs. ccw' (x0 - x) (g a) (g y)" by (auto elim!: linorder_list0.sortedP_Cons simp: ccw'.translate_origin algebra_simps) thus ?case using Cons.prems(1) by (auto elim!: linorder_list0.sortedP_Cons intro!: linorder_list0.sortedP.Cons simp: Cons.hyps) qed lemma ccw'_sortedP_translateI: "linorder_list0.sortedP (ccw' (x0 - x)) (map g xs) ⟹ linorder_list0.sortedP (ccw' x0) (map ((+) x ∘ g) xs)" using ccw'_sortedP_translateD[of "x0 - x" "-x" "(+) x o g" xs] by (simp add: o_def) lemma ccw'_sortedP_translate_comp[simp]: "linorder_list0.sortedP (ccw' x0) (map ((+) x ∘ g) xs) ⟷ linorder_list0.sortedP (ccw' (x0 - x)) (map g xs)" by (metis ccw'_sortedP_translateD ccw'_sortedP_translateI) lemma snd_plus_commute: "snd ∘ (+) (x0, x0) = (+) x0 o snd" by auto lemma ccw'_sortedP_renormalize: "ccw'.sortedP a (map snd (polychain_of (x0 + x) xs)) ⟷ ccw'.sortedP (a - x0) (map snd (polychain_of x xs))" by (simp add: polychain_of_add add.commute snd_plus_commute) lemma ccw'_sortedP_polychain_of01: shows "ccw'.sortedP 0 [u] ⟹ ccw'.sortedP x0 (map snd (polychain_of x0 [u]))" and "ccw'.sortedP 0 [] ⟹ ccw'.sortedP x0 (map snd (polychain_of x0 []))" by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons simp: ac_simps) lemma ccw'_sortedP_polychain_of2: assumes "ccw'.sortedP 0 [u, v]" shows "ccw'.sortedP x0 (map snd (polychain_of x0 [u, v]))" using assms by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons elim!: linorder_list0.sortedP_Cons simp: ac_simps ccw'.translate_origin) lemma ccw'_sortedP_polychain_of3: assumes "ccw'.sortedP 0 (u#v#w#xs)" shows "ccw'.sortedP x0 (map snd (polychain_of x0 (u#v#w#xs)))" using assms proof (induct xs arbitrary: x0 u v w) case Nil then have *: "ccw' 0 u v" "ccw' 0 v w" "ccw' 0 u w" by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons elim!: linorder_list0.sortedP_Cons simp: ac_simps) moreover have "ccw' 0 (u + v) (u + (v + w))" by (metis add.assoc ccw'.add1 ccw'.add3_self *(2-)) ultimately show ?case by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons elim!: linorder_list0.sortedP_Cons simp: ac_simps ccw'.translate_origin ccw'.add3) next case (Cons y ys) have s1: "linorder_list0.sortedP (ccw' 0) ((u + v)#w#y#ys)" using Cons.prems by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons elim!: linorder_list0.sortedP_Cons simp: ccw'.add1) have s2: "linorder_list0.sortedP (ccw' 0) (u#(v + w)#y#ys)" using Cons.prems by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons elim!: linorder_list0.sortedP_Cons simp: ccw'.add3 ccw'.add1) have s3: "linorder_list0.sortedP (ccw' 0) (u#v#(w + y)#ys)" using Cons.prems by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons elim!: linorder_list0.sortedP_Cons simp: ccw'.add3 ccw'.add1) show ?case using Cons.hyps[OF s1, of x0] Cons.hyps[OF s2, of x0] Cons.hyps[OF s3, of x0] Cons.prems by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons elim!: linorder_list0.sortedP_Cons simp: ac_simps) qed lemma ccw'_sortedP_polychain_of_snd: assumes "ccw'.sortedP 0 xs" shows "ccw'.sortedP x0 (map snd (polychain_of x0 xs))" using assms by (metis ccw'_sortedP_polychain_of01 ccw'_sortedP_polychain_of2 ccw'_sortedP_polychain_of3 list.exhaust) lemma ccw'_sortedP_implies_distinct: assumes "ccw'.sortedP x qs" shows "distinct qs" using assms proof induct case Cons thus ?case by (meson ccw'_contra distinct.simps(2)) qed simp lemma ccw'_sortedP_implies_nonaligned: assumes "ccw'.sortedP x qs" assumes "y ∈ set qs" "z ∈ set qs" "y ≠ z" shows "¬ coll x y z" using assms by induct (force simp: ccw'_def det3_def' algebra_simps)+ lemma list_all_mp: "list_all P xs ⟹ (⋀x. x ∈ set xs ⟹ P x ⟹ Q x) ⟹ list_all Q xs" by (auto simp: list_all_iff) lemma ccw'_scale_origin: assumes "e ∈ UNIV → {0<..<1}" assumes "x ∈ set (polychain_of Pc (P # QRRs))" assumes "ccw'.sortedP 0 (P # QRRs)" assumes "ccw' (fst x) (snd x) (P + (Pc + (∑P∈set QRRs. e P *⇩R P)))" shows "ccw' (fst x) (snd x) (e P *⇩R P + (Pc + (∑P∈set QRRs. e P *⇩R P)))" proof - from assms(2) have "fst x = Pc ∧ snd x = Pc + P ∨ x ∈ set (polychain_of (Pc + P) QRRs)" by auto thus ?thesis proof assume x: "x ∈ set (polychain_of (Pc + P) QRRs)" define q where "q = snd x - fst x" from Polygon.in_set_polychain_of_imp_sum_list[OF x] obtain d where d: "fst x = (Pc + P + sum_list (take d QRRs))" by (auto simp: prod_eq_iff) from in_set_polychain_ofD[OF x] have q_in: "q ∈ set QRRs" by (simp add: q_def) define R where "R = set QRRs - {q}" hence QRRs: "set QRRs = R ∪ {q}" "q ∉ R" "finite R" using q_in by auto have "ccw' 0 q (-P)" using assms(3) by (auto simp: ccw'.sortedP_Cons_iff q_in) hence "ccw' 0 q ((1 - e P) *⇩R (-P))" using assms(1) by (subst ccw'.scaleR2_eq) (auto simp: algebra_simps) moreover from assms(4) have "ccw' 0 q ((∑P∈set QRRs. e P *⇩R P) - sum_list (take d QRRs))" by (auto simp: q_def ccw'.translate_origin d) ultimately have "ccw' 0 q ((1 - e P) *⇩R (-P) + ((∑P∈set QRRs. e P *⇩R P) - sum_list (take d QRRs)))" by (intro ccw'.add3) auto thus ?thesis by (auto simp: ccw'.translate_origin q_def algebra_simps d) qed (metis (no_types, lifting) add.left_commute assms(4) ccw'.add3_self ccw'.scale_add3 ccw'.translate) qed lemma polychain_of_ccw_convex: assumes "e ∈ UNIV → {0 <..< 1}" assumes sorted: "linorder_list0.sortedP (ccw' 0) (P#Q#Ps)" shows "list_all (λ(xi, xj). ccw' xi xj (Pc + (∑P ∈ set (P#Q#Ps). e P *⇩R P))) (polychain_of Pc (P#Q#Ps))" using assms(1) assms(2) proof (induct Ps arbitrary: P Q Pc) case Nil have eq: "e P *⇩R P + e Q *⇩R Q - P = (1 - e P) *⇩R (- P) + e Q *⇩R Q" using ‹e ∈ _› by (auto simp add: algebra_simps) from Nil ccw'_sortedP_implies_distinct[OF Nil(2)] have "P ≠ Q" "e P < 1" "0 < e Q" "ccw' 0 P Q" by (auto elim!: linorder_list0.sortedP_Cons) thus ?case by (auto simp: ccw'_not_coll ccw'.translate_origin eq) next case (Cons R Rs) hence "ccw' 0 P Q" "P ≠ Q" using ccw'_sortedP_implies_distinct[OF Cons(3)] by (auto elim!: linorder_list0.sortedP_Cons) have "list_all (λ(xi, xj). ccw' xi xj ((Pc + P) + (∑P∈set (Q # R # Rs). e P *⇩R P))) (polychain_of (Pc + P) (Q # R # Rs))" using Cons(2-) by (intro Cons(1)) (auto elim: linorder_list0.sortedP_Cons) also have "polychain_of (Pc + P) (Q # R # Rs) = tl (polychain_of Pc (P # Q # R # Rs))" by simp finally have "list_all (λ(xi, xj). ccw' xi xj (Pc + P + (∑P∈set (Q # R # Rs). e P *⇩R P))) (tl (polychain_of Pc (P # Q # R # Rs)))" . moreover have "list_all (λ(xi, xj). ccw' xi xj (P + (∑P∈set (Q # R # Rs). e P *⇩R P))) (polychain_of P (Q # R # Rs))" using Cons(2-) by (intro Cons(1)) (auto elim: linorder_list0.sortedP_Cons) have "(λ(xi, xj). ccw' xi xj (Pc + P + (∑P∈set (Q # R # Rs). e P *⇩R P))) (hd (polychain_of Pc (P # Q # R # Rs)))" using ccw'_sortedP_implies_nonaligned[OF Cons(3), of P Q] ccw'_sortedP_implies_nonaligned[OF Cons(3), of Q R] ccw'_sortedP_implies_nonaligned[OF Cons(3), of P R] Cons(2,3) by (auto simp add: Pi_iff add.assoc simp del: scaleR_Pair intro!: ccw'.sum elim!: linorder_list0.sortedP_Cons) ultimately have "list_all (λ(xi, xj). ccw' xi xj (P + (Pc + (∑P∈set (Q # R # Rs). e P *⇩R P)))) (polychain_of Pc (P # Q # R # Rs))" by (simp add: ac_simps) hence "list_all (λ(xi, xj). ccw' xi xj (e P *⇩R P + (Pc + (∑P∈set (Q # R # Rs). e P *⇩R P)))) (polychain_of Pc (P # Q # R # Rs))" unfolding split_beta' by (rule list_all_mp, intro ccw'_scale_origin[OF assms(1)]) (auto intro!: ccw'_scale_origin Cons(3)) thus ?case using ccw'_sortedP_implies_distinct[OF Cons(3)] Cons by (simp add: ac_simps) qed lemma polychain_of_ccw: assumes "e ∈ UNIV → {0 <..< 1}" assumes sorted: "ccw'.sortedP 0 qs" assumes qs: "length qs ≠ 1" shows "list_all (λ(xi, xj). ccw' xi xj (Pc + (∑P ∈ set qs. e P *⇩R P))) (polychain_of Pc qs)" using assms proof (cases qs) case (Cons Q Qs) note CQ = this show ?thesis using assms proof (cases Qs) case (Cons R Rs) thus ?thesis using assms unfolding CQ Cons by (intro polychain_of_ccw_convex) (auto simp: CQ Cons intro!: polychain_of_ccw_convex) qed (auto simp: CQ) qed simp lemma in_polychain_of_ccw: assumes "e ∈ UNIV → {0 <..< 1}" assumes "ccw'.sortedP 0 qs" assumes "length qs ≠ 1" assumes "seg ∈ set (polychain_of Pc qs)" shows "ccw' (fst seg) (snd seg) (Pc + (∑P ∈ set qs. e P *⇩R P))" using polychain_of_ccw[OF assms(1,2,3)] assms(4) by (simp add: list_all_iff split_beta) lemma distinct_butlast_ne_last: "distinct xs ⟹ x ∈ set (butlast xs) ⟹ x ≠ last xs" by (metis append_butlast_last_id distinct_butlast empty_iff in_set_butlastD list.set(1) not_distinct_conv_prefix) lemma ccw'_sortedP_convex_rotate_aux: assumes "ccw'.sortedP 0 (zs)" "ccw'.sortedP x (map snd (polychain_of x (zs)))" shows "ccw'.sortedP (snd (last (polychain_of x (zs)))) (map snd (butlast (polychain_of x (zs))))" using assms proof (induct zs arbitrary: x rule: list.induct) case (Cons z zs) { assume "zs ≠ []" have "ccw'.sortedP (snd (last (polychain_of (x + z) zs))) (map snd (butlast (polychain_of (x + z) zs)))" using Cons.prems by (auto elim!: ccw'.sortedP_Cons intro!: ccw'_sortedP_polychain_of_snd Cons.hyps) from _ this have "linorder_list0.sortedP (ccw' (snd (last (polychain_of (x + z) zs)))) ((x + z) # map snd (butlast (polychain_of (x + z) zs)))" proof (rule ccw'.sortedP.Cons, safe) fix c d assume cd: "(c, d) ∈ set (map snd (butlast (polychain_of (x + z) zs)))" then obtain a b where ab: "((a, b), c, d) ∈ set (butlast (polychain_of (x + z) zs))" by auto have cd': "(c, d) ∈ set (butlast (map snd (polychain_of (x + z) zs)))" using cd by (auto simp: map_butlast) have "ccw' (x + z) (c, d) (last (map snd (polychain_of (x + z) zs)))" proof (rule ccw'.sortedP_right_of_last) show "ccw'.sortedP (x + z) (map snd (polychain_of (x + z) zs))" using Cons by (force intro!: ccw'.sortedP.Cons ccw'.sortedP.Nil ccw'_sortedP_polychain_of_snd elim!: ccw'.sortedP_Cons) show "(c, d) ∈ set (map snd (polychain_of (x + z) zs))" using in_set_butlastD[OF ab] by force from Cons(3) cd' show "(c, d) ≠ last (map snd (polychain_of (x + z) zs))" by (intro distinct_butlast_ne_last ccw'_sortedP_implies_distinct[where x=x]) (auto elim!: ccw'.sortedP_Cons) qed thus "ccw' (snd (last (polychain_of (x + z) zs))) (x + z) (c, d)" by (auto simp: last_map[symmetric, where f= snd] ‹zs ≠ []› intro: ccw'.cyclicI) qed } thus ?case by (auto simp: ccw'.sortedP.Nil) qed (simp add: ccw'.sortedP.Nil) lemma ccw'_polychain_of_sorted_center_last: assumes set_butlast: "(c, d) ∈ set (butlast (polychain_of x0 xs))" assumes sorted: "ccw'.sortedP 0 xs" assumes ne: "xs ≠ []" shows "ccw' x0 d (snd (last (polychain_of x0 xs)))" proof - from ccw'_sortedP_polychain_of_snd[OF sorted, of x0] have "ccw'.sortedP x0 (map snd (polychain_of x0 xs))" . also from set_butlast obtain ys zs where "butlast (polychain_of x0 xs) = ys@((c, d)#zs)" by (auto simp add: in_set_conv_decomp) hence "polychain_of x0 xs = ys @ (c, d) # zs @ [last (polychain_of x0 xs)]" by (metis append_Cons append_assoc append_butlast_last_id ne polychain_of_eq_empty_iff) finally show ?thesis by (auto elim!: ccw'.sortedP_Cons simp: ccw'.sortedP_append_iff) qed end
section ‹CCW for Arbitrary Points in the Plane› theory Counterclockwise_2D_Arbitrary imports Counterclockwise_2D_Strict begin subsection ‹Interpretation of Knuth's axioms in the plane› definition lex::"point ⇒ point ⇒ bool" where "lex p q ⟷ (fst p < fst q ∨ fst p = fst q ∧ snd p < snd q ∨ p = q)" definition psi::"point ⇒ point ⇒ point ⇒ bool" where "psi p q r ⟷ (lex p q ∧ lex q r)" definition ccw::"point ⇒ point ⇒ point ⇒ bool" where "ccw p q r ⟷ ccw' p q r ∨ (det3 p q r = 0 ∧ (psi p q r ∨ psi q r p ∨ psi r p q))" interpretation ccw: linorder_list0 "ccw x" for x . lemma ccw'_imp_ccw: "ccw' a b c ⟹ ccw a b c" by (simp add: ccw_def) lemma ccw_ncoll_imp_ccw: "ccw a b c ⟹ ¬coll a b c ⟹ ccw' a b c" by (simp add: ccw_def) lemma ccw_translate: "ccw p (p + q) (p + r) = ccw 0 q r" by (auto simp: ccw_def psi_def lex_def) lemma ccw_translate_origin: "NO_MATCH 0 p ⟹ ccw p q r = ccw 0 (q - p) (r - p)" using ccw_translate[of p "q - p" "r - p"] by simp lemma psi_scale: "psi (r *⇩R a) (r *⇩R b) 0 = (if r > 0 then psi a b 0 else if r < 0 then psi 0 b a else True)" "psi (r *⇩R a) 0 (r *⇩R b) = (if r > 0 then psi a 0 b else if r < 0 then psi b 0 a else True)" "psi 0 (r *⇩R a) (r *⇩R b) = (if r > 0 then psi 0 a b else if r < 0 then psi b a 0 else True)" by (auto simp: psi_def lex_def det3_def' not_less algebra_split_simps) lemma ccw_scale23: "ccw 0 a b ⟹ r > 0 ⟹ ccw 0 (r *⇩R a) (r *⇩R b)" by (auto simp: ccw_def psi_scale) lemma psi_notI: "distinct3 p q r ⟹ psi p q r ⟹ ¬ psi q p r" by (auto simp: algebra_simps psi_def lex_def) lemma not_lex_eq: "¬ lex a b ⟷ lex b a ∧ a ≠ b" by (auto simp: algebra_simps lex_def prod_eq_iff) lemma lex_trans: "lex a b ⟹ lex b c ⟹ lex a c" by (auto simp: lex_def) lemma lex_sym_eqI: "lex a b ⟹ lex b a ⟹ a = b" and lex_sym_eq_iff: "lex a b ⟹ lex b a ⟷ a = b" by (auto simp: lex_def) lemma lex_refl[simp]: "lex p p" by (metis not_lex_eq) lemma psi_disjuncts: "distinct3 p q r ⟹ psi p q r ∨ psi p r q ∨ psi q r p ∨ psi q p r ∨ psi r p q ∨ psi r q p" by (auto simp: psi_def not_lex_eq) lemma nlex_ccw_left: "lex x 0 ⟹ ccw 0 (0, 1) x" by (auto simp: ccw_def lex_def psi_def ccw'_def det3_def') interpretation ccw_system123 ccw apply unfold_locales subgoal by (force simp: ccw_def ccw'_def det3_def' algebra_simps) subgoal by (force simp: ccw_def ccw'_def det3_def' psi_def algebra_simps lex_sym_eq_iff) subgoal by (drule psi_disjuncts) (force simp: ccw_def ccw'_def det3_def' algebra_simps) done lemma lex_scaleR_nonneg: "lex a b ⟹ r ≥ 0 ⟹ lex a (a + r *⇩R (b - a))" by (auto simp: lex_def) lemma lex_scale1_zero: "lex (v *⇩R u) 0 = (if v > 0 then lex u 0 else if v < 0 then lex 0 u else True)" and lex_scale2_zero: "lex 0 (v *⇩R u) = (if v > 0 then lex 0 u else if v < 0 then lex u 0 else True)" by (auto simp: lex_def prod_eq_iff less_eq_prod_def algebra_split_simps) lemma nlex_add: assumes "lex a 0" "lex b 0" shows "lex (a + b) 0" using assms by (auto simp: lex_def) lemma nlex_sum: assumes "finite X" assumes "⋀x. x ∈ X ⟹ lex (f x) 0" shows "lex (sum f X) 0" using assms by induction (auto intro!: nlex_add) lemma abs_add_nlex: assumes "coll 0 a b" assumes "lex a 0" assumes "lex b 0" shows "abs (a + b) = abs a + abs b" proof (rule antisym[OF abs_triangle_ineq]) have "fst (¦a¦ + ¦b¦) ≤ fst ¦a + b¦" using assms by (auto simp add: det3_def' abs_prod_def lex_def) moreover { assume H: "fst a < 0" "fst b < 0" hence "snd b ≤ 0 ⟷ snd a ≤ 0" using assms by (auto simp: lex_def det3_def' mult.commute) (metis mult_le_cancel_left_neg mult_zero_right)+ hence "¦snd a¦ + ¦snd b¦ ≤ ¦snd a + snd b¦" using H by auto } hence "snd (¦a¦ + ¦b¦) ≤ snd ¦a + b¦" using assms by (auto simp add: det3_def' abs_prod_def lex_def) ultimately show "¦a¦ + ¦b¦ ≤ ¦a + b¦" unfolding less_eq_prod_def .. qed lemma lex_sum_list: "(⋀x. x ∈ set xs ⟹ lex x 0) ⟹ lex (sum_list xs) 0" by (induct xs) (auto simp: nlex_add) lemma abs_sum_list_coll: assumes coll: "list_all (coll 0 x) xs" assumes "x ≠ 0" assumes up: "list_all (λx. lex x 0) xs" shows "abs (sum_list xs) = sum_list (map abs xs)" using assms proof (induct xs) case (Cons y ys) hence "coll 0 x y" "coll 0 x (sum_list ys)" by (auto simp: list_all_iff intro!: coll_sum_list) hence "coll 0 y (sum_list ys)" using ‹x ≠ 0› by (rule coll_trans) hence "¦y + sum_list ys¦ = abs y + abs (sum_list ys)" using Cons by (subst abs_add_nlex) (auto simp: list_all_iff lex_sum_list) thus ?case using Cons by simp qed simp lemma lex_diff1: "lex (a - b) c = lex a (c + b)" and lex_diff2: "lex c (a - b) = lex (c + b) a" by (auto simp: lex_def) lemma sum_list_eq_0_iff_nonpos: fixes xs::"'a::ordered_ab_group_add list" shows "list_all (λx. x ≤ 0) xs ⟹ sum_list xs = 0 ⟷ (∀n∈set xs. n = 0)" by (auto simp: list_all_iff sum_list_sum_nth sum_nonpos_eq_0_iff) (auto simp add: in_set_conv_nth) lemma sum_list_nlex_eq_zeroI: assumes nlex: "list_all (λx. lex x 0) xs" assumes "sum_list xs = 0" assumes "x ∈ set xs" shows "x = 0" proof - from assms(2) have z1: "sum_list (map fst xs) = 0" and z2: "sum_list (map snd xs) = 0" by (auto simp: prod_eq_iff fst_sum_list snd_sum_list) from nlex have "list_all (λx. x ≤ 0) (map fst xs)" by (auto simp: lex_def list_all_iff) from sum_list_eq_0_iff_nonpos[OF this] z1 nlex have z1': "list_all (λx. x = 0) (map fst xs)" and "list_all (λx. x ≤ 0) (map snd xs)" by (auto simp: list_all_iff lex_def) from sum_list_eq_0_iff_nonpos[OF this(2)] z2 have "list_all (λx. x = 0) (map snd xs)" by (simp add: list_all_iff) with z1' show "x = 0" by (auto simp: list_all_iff zero_prod_def assms prod_eq_iff) qed lemma sum_list_eq0I: "(∀x∈set xs. x = 0) ⟹ sum_list xs = 0" by (induct xs) auto lemma sum_list_nlex_eq_zero_iff: assumes nlex: "list_all (λx. lex x 0) xs" shows "sum_list xs = 0 ⟷ list_all ((=) 0) xs" using assms by (auto intro: sum_list_nlex_eq_zeroI sum_list_eq0I simp: list_all_iff) lemma assumes "lex p q" "lex q r" "0 ≤ a" "0 ≤ b" "0 ≤ c" "a + b + c = 1" assumes comb_def: "comb = a *⇩R p + b *⇩R q + c *⇩R r" shows lex_convex3: "lex p comb" "lex comb r" proof - from convex3_alt[OF assms(3-6), of p q r] obtain u v where uv: "a *⇩R p + b *⇩R q + c *⇩R r = p + u *⇩R (q - p) + v *⇩R (r - p)" "0 ≤ u" "0 ≤ v" "u + v ≤ 1" . have "lex p r" using assms by (metis lex_trans) hence "lex (v *⇩R (p - r)) 0" using uv by (simp add: lex_scale1_zero lex_diff1) also have "lex 0 (u *⇩R (q - p))" using ‹lex p q› uv by (simp add: lex_scale2_zero lex_diff2) finally (lex_trans) show "lex p comb" unfolding comb_def uv by (simp add: lex_def prod_eq_iff algebra_simps) from comb_def have comb_def': "comb = c *⇩R r + b *⇩R q + a *⇩R p" by simp from assms have "c + b + a = 1" by simp from convex3_alt[OF assms(5,4,3) this, of r q p] obtain u v where uv: "c *⇩R r + b *⇩R q + a *⇩R p = r + u *⇩R (q - r) + v *⇩R (p - r)" "0 ≤ u" "0 ≤ v" "u + v ≤ 1" by auto have "lex (u *⇩R (q - r)) 0" using uv ‹lex q r› by (simp add: lex_scale1_zero lex_diff1) also have "lex 0 (v *⇩R (r - p))" using uv ‹lex p r› by (simp add: lex_scale2_zero lex_diff2) finally (lex_trans) show "lex comb r" unfolding comb_def' uv by (simp add: lex_def prod_eq_iff algebra_simps) qed lemma lex_convex_self2: assumes "lex p q" "0 ≤ a" "a ≤ 1" defines "r ≡ a *⇩R p + (1 - a) *⇩R q" shows "lex p r" (is ?th1) and "lex r q" (is ?th2) using lex_convex3[OF ‹lex p q›, of q a "1 - a" 0 r] assms by (simp_all add: r_def) lemma lex_uminus0[simp]: "lex (-a) 0 = lex 0 a" by (auto simp: lex_def) lemma lex_fst_zero_imp: "fst x = 0 ⟹ lex x 0 ⟹ lex y 0 ⟹ ¬coll 0 x y ⟹ ccw' 0 y x" by (auto simp: ccw'_def det3_def' lex_def algebra_split_simps) lemma lex_ccw_left: "lex x y ⟹ r > 0 ⟹ ccw y (y + (0, r)) x" by (auto simp: ccw_def ccw'_def det3_def' algebra_simps lex_def psi_def) lemma lex_translate_origin: "NO_MATCH 0 a ⟹ lex a b = lex 0 (b - a)" by (auto simp: lex_def) subsection ‹Order prover setup› definition "lexs p q ⟷ (lex p q ∧ p ≠ q)" lemma lexs_irrefl: "¬ lexs p p" and lexs_imp_lex: "lexs x y ⟹ lex x y" and not_lexs: "(¬ lexs x y) = (lex y x)" and not_lex: "(¬ lex x y) = (lexs y x)" and eq_lex_refl: "x = y ⟹ lex x y" by (auto simp: lexs_def lex_def prod_eq_iff) lemma lexs_trans: "lexs x y ⟹ lexs y z ⟹ lexs x z" and lexs_lex_trans: "lexs x y ⟹ lex y z ⟹ lexs x z" and lex_lexs_trans: "lex x y ⟹ lexs y z ⟹ lexs x z" and lex_neq_trans: "lex a b ⟹ a ≠ b ⟹ lexs a b" and neq_lex_trans: "a ≠ b ⟹ lex a b ⟹ lexs a b" and lexs_imp_neq: "lexs a b ⟹ a ≠ b" by (auto simp: lexs_def lex_def prod_eq_iff) declare lexs_irrefl[THEN notE, order add less_reflE: linorder "(=) :: point => point => bool" lex lexs] declare lex_refl[order add le_refl: linorder "(=) :: point => point => bool" lex lexs] declare lexs_imp_lex[order add less_imp_le: linorder "(=) :: point => point => bool" lex lexs] declare not_lexs[THEN iffD2, order add not_lessI: linorder "(=) :: point => point => bool" lex lexs] declare not_lex[THEN iffD2, order add not_leI: linorder "(=) :: point => point => bool" lex lexs] declare not_lexs[THEN iffD1, order add not_lessD: linorder "(=) :: point => point => bool" lex lexs] declare not_lex[THEN iffD1, order add not_leD: linorder "(=) :: point => point => bool" lex lexs] declare lex_sym_eqI[order add eqI: linorder "(=) :: point => point => bool" lex lexs] declare eq_lex_refl[order add eqD1: linorder "(=) :: point => point => bool" lex lexs] declare sym[THEN eq_lex_refl, order add eqD2: linorder "(=) :: point => point => bool" lex lexs] declare lexs_trans[order add less_trans: linorder "(=) :: point => point => bool" lex lexs] declare lexs_lex_trans[order add less_le_trans: linorder "(=) :: point => point => bool" lex lexs] declare lex_lexs_trans[order add le_less_trans: linorder "(=) :: point => point => bool" lex lexs] declare lex_trans[order add le_trans: linorder "(=) :: point => point => bool" lex lexs] declare lex_neq_trans[order add le_neq_trans: linorder "(=) :: point => point => bool" lex lexs] declare neq_lex_trans[order add neq_le_trans: linorder "(=) :: point => point => bool" lex lexs] declare lexs_imp_neq[order add less_imp_neq: linorder "(=) :: point => point => bool" lex lexs] declare eq_neq_eq_imp_neq[order add eq_neq_eq_imp_neq: linorder "(=) :: point => point => bool" lex lexs] declare not_sym[order add not_sym: linorder "(=) :: point => point => bool" lex lexs] subsection ‹Contradictions› lemma assumes d: "distinct4 s p q r" shows contra1: "¬(lex p q ∧ lex q r ∧ lex r s ∧ indelta s p q r)" (is ?th1) and contra2: "¬(lex s p ∧ lex p q ∧ lex q r ∧ indelta s p q r)" (is ?th2) and contra3: "¬(lex p r ∧ lex p s ∧ lex q r ∧ lex q s ∧ insquare p r q s)" (is ?th3) proof - { assume "det3 s p q = 0" "det3 s q r = 0" "det3 s r p = 0" "det3 p q r = 0" hence ?th1 ?th2 ?th3 using d by (auto simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps) } moreover { assume *: "¬(det3 s p q = 0 ∧ det3 s q r = 0 ∧ det3 s r p = 0 ∧ det3 p q r = 0)" { assume d0: "det3 p q r = 0" with d have "?th1 ∧ ?th2" by (force simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps) } moreover { assume dp: "det3 p q r ≠ 0" have "?th1 ∧ ?th2" unfolding de_Morgan_disj[symmetric] proof (rule notI, goal_cases) case prems: 1 hence **: "indelta s p q r" by auto hence nonnegs: "det3 p q r ≥ 0" "0 ≤ det3 s q r" "0 ≤ det3 p s r" "0 ≤ det3 p q s" by (auto simp: ccw_def ccw'_def det3_def' algebra_simps) hence det_pos: "det3 p q r > 0" using dp by simp have det_eq: "det3 s q r + det3 p s r + det3 p q s = det3 p q r" by (auto simp: ccw_def det3_def' algebra_simps) hence det_div_eq: "det3 s q r / det3 p q r + det3 p s r / det3 p q r + det3 p q s / det3 p q r = 1" using det_pos by (auto simp: field_simps) from lex_convex3[OF _ _ _ _ _ det_div_eq convex_comb_dets[OF det_pos, of s]] have "lex p s" "lex s r" using prems by (auto simp: nonnegs) with prems d show False by (simp add: lex_sym_eq_iff) qed } moreover have ?th3 proof (safe, goal_cases) case prems: 1 have nonnegs: "det3 p r q ≥ 0" "det3 r q s ≥ 0" "det3 s p r ≥ 0" "det3 q s p ≥ 0" using prems by (auto simp add: ccw_def ccw'_def less_eq_real_def) have dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r" by (auto simp: det3_def') hence **: "det3 p r q = 0 ∧ det3 q s p = 0 ⟹ det3 r q s = 0 ∧ det3 s p r = 0" using prems by (auto simp: ccw_def ccw'_def) moreover { fix p r q s assume det_pos: "det3 p r q > 0" assume dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r" assume nonnegs:"det3 r q s ≥ 0" "det3 s p r ≥ 0" "det3 q s p ≥ 0" assume g14: "lex p r" "lex p s" "lex q r" "lex q s" assume d: "distinct4 s p q r" let ?sum = "(det3 p r q + det3 q s p) / det3 p r q" have eqs: "det3 s p r = det3 p r s" "det3 r q s = det3 s r q" "det3 q s p = - det3 p s q" by (auto simp: det3_def' algebra_simps) from convex_comb_dets[OF det_pos, of s] have "((det3 p r q / det3 p r q) *⇩R s + (det3 q s p / det3 p r q) *⇩R r) /⇩R ?sum = ((det3 r q s / det3 p r q) *⇩R p + (det3 s p r / det3 p r q) *⇩R q) /⇩R ?sum" unfolding eqs by (simp add: algebra_simps prod_eq_iff) hence srpq: "(det3 p r q / det3 p r q / ?sum) *⇩R s + (det3 q s p / det3 p r q / ?sum) *⇩R r = (det3 r q s / det3 p r q / ?sum) *⇩R p + (det3 s p r / det3 p r q / ?sum) *⇩R q" (is "?s *⇩R s + ?r *⇩R r = ?p *⇩R p + ?q *⇩R q") using det_pos by (simp add: algebra_simps inverse_eq_divide) have eqs: "?s + ?r = 1" "?p + ?q = 1" and s: "?s ≥ 0" "?s ≤ 1" and r: "?r ≥ 0" "?r ≤ 1" and p: "?p ≥ 0" "?p ≤ 1" and q: "?q ≥ 0" "?q ≤ 1" unfolding add_divide_distrib[symmetric] using det_pos nonnegs dets_eq by (auto) from eqs have eqs': "1 - ?s = ?r" "1 - ?r = ?s" "1 - ?p = ?q" "1 - ?q = ?p" by auto have comm: "?r *⇩R r + ?s *⇩R s = ?s *⇩R s + ?r *⇩R r" "?q *⇩R q + ?p *⇩R p = ?p *⇩R p + ?q *⇩R q" by simp_all define K where "K = (det3 r q s / det3 p r q / ?sum) *⇩R p + (det3 s p r / det3 p r q / ?sum) *⇩R q" note rewrs = eqs' comm srpq K_def[symmetric] from lex_convex_self2[OF _ s, of s r, unfolded rewrs] lex_convex_self2[OF _ r, of r s, unfolded rewrs] lex_convex_self2[OF _ p, of p q, unfolded rewrs] lex_convex_self2[OF _ q, of q p, unfolded rewrs] have False using g14 d det_pos by (metis lex_trans not_lex_eq) } note wlog = this from dets_eq have 1: "det3 q s p + det3 p r q = det3 s p r + det3 r q s" by simp from d have d': "distinct4 r q p s" by auto note wlog[of q s p r, OF _ 1 nonnegs(3,2,1) prems(4,3,2,1) d'] wlog[of p r q s, OF _ dets_eq nonnegs(2,3,4) prems(1-4) d] ultimately show False using nonnegs d * by (auto simp: less_eq_real_def det3_def' algebra_simps) qed ultimately have ?th1 ?th2 ?th3 by blast+ } ultimately show ?th1 ?th2 ?th3 by force+ qed lemma ccw'_subst_psi_disj: assumes "det3 t r s = 0" assumes "psi t r s ∨ psi t s r ∨ psi s r t" assumes "s ≠ t" assumes "ccw' t r p" shows "ccw' t s p" proof cases assume "r ≠ s" from assms have "r ≠ t" by (auto simp: det3_def' ccw'_def algebra_simps) from assms have "det3 r s t = 0" by (auto simp: algebra_simps det3_def') from coll_ex_scaling[OF assms(3) this] obtain x where s: "r = s + x *⇩R (t - s)" by auto from assms(4)[simplified s] have "0 < det3 0 (s + x *⇩R (t - s) - t) (p - t)" by (auto simp: algebra_simps det3_def' ccw'_def) also have "s + x *⇩R (t - s) - t = (1 - x) *⇩R (s - t)" by (simp add: algebra_simps) finally have ccw': "ccw' 0 ((1 - x) *⇩R (s - t)) (p - t)" by (simp add: ccw'_def) hence neq: "x ≠ 1" by (auto simp add: det3_def' ccw'_def) have tr: "fst s < fst r ⟹ fst t = fst s ⟹ snd t ≤ snd r" by (simp add: s) from s have "fst (r - s) = fst (x *⇩R (t - s))" "snd (r - s) = snd (x *⇩R (t - s))" by (auto simp: ) hence "x = (if fst (t - s) = 0 then snd (r - s) / snd (t - s) else fst (r - s) / fst (t - s))" using ‹s ≠ t› by (auto simp add: field_simps prod_eq_iff) also have "… ≤ 1" using assms by (auto simp: lex_def psi_def tr) finally have "x < 1" using neq by simp thus ?thesis using ccw' by (auto simp: ccw'.translate_origin) qed (insert assms, simp) lemma lex_contr: assumes "distinct4 t s q r" assumes "lex t s" "lex s r" assumes "det3 t s r = 0" assumes "ccw' t s q" assumes "ccw' t q r" shows "False" using ccw'_subst_psi_disj[of t s r q] assms by (cases "r = t") (auto simp: det3_def' algebra_simps psi_def ccw'_def) lemma contra4: assumes "distinct4 s r q p" assumes lex: "lex q p" "lex p r" "lex r s" assumes ccw: "ccw r q s" "ccw r s p" "ccw r q p" shows False proof cases assume c: "ccw s q p" from c have *: "indelta s r q p" using assms by simp with contra1[OF assms(1)] have "¬ (lex r q ∧ lex q p ∧ lex p s)" by blast hence "¬ lex q p" using ‹ccw s q p› contra1 cyclic assms nondegenerate by blast thus False using assms by simp next assume "¬ ccw s q p" with ccw have "ccw q s p ∧ ccw s p r ∧ ccw p r q ∧ ccw r q s" by (metis assms(1) ccw'.cyclic ccw_def not_ccw'_eq psi_disjuncts) moreover from lex have "lex q r" "lex q s" "lex p r" "lex p s" by order+ ultimately show False using contra3[of r q p s] ‹distinct4 s r q p› by blast qed lemma not_coll_ordered_lexI: assumes "l ≠ x0" and "lex x1 r" and "lex x1 l" and "lex r x0" and "lex l x0" and "ccw' x0 l x1" and "ccw' x0 x1 r" shows "det3 x0 l r ≠ 0" proof assume "coll x0 l r" from ‹coll x0 l r› have 1: "coll 0 (l - x0) (r - x0)" by (simp add: det3_def' algebra_simps) from ‹lex r x0› have 2: "lex (r - x0) 0" by (auto simp add: lex_def) from ‹lex l x0› have 3: "lex (l - x0) 0" by (auto simp add: lex_def) from ‹ccw' x0 l x1› have 4: "ccw' 0 (l - x0) (x1 - x0)" by (simp add: det3_def' ccw'_def algebra_simps) from ‹ccw' x0 x1 r› have 5: "ccw' 0 (x1 - x0) (r - x0)" by (simp add: det3_def' ccw'_def algebra_simps) from ‹lex x1 r› have 6: "lex 0 (r - x0 - (x1 - x0))" by (auto simp: lex_def) from ‹lex x1 l› have 7: "lex 0 (l - x0 - (x1 - x0))" by (auto simp: lex_def) define r' where "r' = r - x0" define l' where "l' = l - x0" define x0' where "x0' = x1 - x0" from 1 2 3 4 5 6 7 have rs: "coll 0 l' r'" "lex r' 0" "lex l' 0" "ccw' 0 l' x0'" "ccw' 0 x0' r'" "lex 0 (r' - x0')" "lex 0 (l' - x0')" unfolding r'_def[symmetric] l'_def[symmetric] x0'_def[symmetric] by auto from assms have "l' ≠ 0" by (auto simp: l'_def) from coll_scale[OF ‹coll 0 l' _› this] obtain y where y: "r' = y *⇩R l'" by auto { assume "y > 0" with rs have False by (auto simp: det3_def' algebra_simps y ccw'_def) } moreover { assume "y < 0" with rs have False by (auto simp: lex_def not_less algebra_simps algebra_split_simps y ccw'_def) } moreover { assume "y = 0" from this rs have False by (simp add: ccw'_def y) } ultimately show False by arith qed interpretation ccw_system4 ccw proof unfold_locales fix p q r t assume ccw: "ccw t q r" "ccw p t r" "ccw p q t" show "ccw p q r" proof (cases "det3 t q r = 0 ∧ det3 p t r = 0 ∧ det3 p q t = 0") case True { assume "psi t q r ∨ psi q r t ∨ psi r t q" "psi p t r ∨ psi t r p ∨ psi r p t" "psi p q t ∨ psi q t p ∨ psi t p q" hence "psi p q r ∨ psi q r p ∨ psi r p q" using lex_sym_eq_iff psi_def by blast } with True ccw show ?thesis by (simp add: det3_def' algebra_simps ccw_def ccw'_def) next case False hence "0 ≤ det3 t q r" "0 ≤ det3 p t r" "0 ≤ det3 p q t" using ccw by (auto simp: less_eq_real_def ccw_def ccw'_def) with False show ?thesis by (auto simp: ccw_def det3_def' algebra_simps ccw'_def intro!: disjI1) qed qed lemma lex_total: "lex t q ∧ t ≠ q ∨ lex q t ∧ t ≠ q ∨ t = q" by auto lemma ccw_two_up_contra: assumes c: "ccw' t p q" "ccw' t q r" assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p" assumes distinct: "distinct5 t s p q r" shows False proof - from ccws have nn: "det3 t s p ≥ 0" "det3 t s q ≥ 0" "det3 t s r ≥ 0" "det3 t r p ≥ 0" by (auto simp add: less_eq_real_def ccw_def ccw'_def) with c det_identity[of t p q s r] have tsr: "coll t s r" and tsp: "coll t s p" by (auto simp: add_nonneg_eq_0_iff ccw'_def) moreover have trp: "coll t r p" by (metis ccw'_subst_collinear distinct not_ccw'_eq tsr tsp) ultimately have tpr: "coll t p r" by (auto simp: det3_def' algebra_simps) moreover have psi: "psi t p r ∨ psi t r p ∨ psi r p t" unfolding psi_def proof - have ntsr: "¬ ccw' t s r" "¬ ccw' t r s" using tsr by (auto simp: not_ccw'_eq det3_def' algebra_simps) have f8: "¬ ccw' t r s" using tsr not_ccw'_eq by blast have f9: "¬ ccw' t r p" using tpr by (simp add: not_ccw'_eq) have f10: "(lex t r ∧ lex r p ∨ lex r p ∧ lex p t ∨ lex p t ∧ lex t r)" using ccw_def ccws(6) psi_def f9 by auto have "¬ ccw' t r q" using c(2) not_ccw'_eq by blast moreover have "¬coll t q s" using ntsr ccw'_subst_collinear distinct c(2) by blast hence "ccw' t s q" by (meson ccw_def ccws(2) not_ccw'_eq) moreover from tsr tsp ‹coll t r p› have "coll t p s" "coll t p r" "coll t r s" by (auto simp add: det3_def' algebra_simps) ultimately show "lex t p ∧ lex p r ∨ lex t r ∧ lex r p ∨ lex r p ∧ lex p t" by (metis ccw'_subst_psi_disj distinct ccw_def ccws(3) contra4 tsp ntsr(1) f10 lex_total psi_def trp) qed moreover from distinct have "r ≠ t" by auto ultimately have "ccw' t r q" using c(1) by (rule ccw'_subst_psi_disj) thus False using c(2) by (simp add: ccw'_contra) qed lemma ccw_transitive_contr: fixes t s p q r assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p" assumes distinct: "distinct5 t s p q r" shows False proof - from ccws distinct have *: "ccw p t r" "ccw p q t" by (metis cyclic)+ with distinct have "ccw r p q" using interior[OF _ _ ccws(5) *, of UNIV] by (auto intro: cyclic) from ccws have nonnegs: "det3 t s p ≥ 0" "det3 t s q ≥ 0" "det3 t s r ≥ 0" "det3 t p q ≥ 0" "det3 t q r ≥ 0" "det3 t r p ≥ 0" by (auto simp add: less_eq_real_def ccw_def ccw'_def) { assume "ccw' t p q" "ccw' t q r" "ccw' t r p" hence False using ccw_two_up_contra ccws distinct by blast } moreover { assume c: "coll t q r" "coll t r p" with distinct four_points_aligned(1)[OF c, of s] have "coll t p q" by auto hence "(psi t p q ∨ psi p q t ∨ psi q t p)" "psi t q r ∨ psi q r t ∨ psi r t q" "psi t r p ∨ psi r p t ∨ psi p t r" using ccws(4,5,6) c by (simp_all add: ccw_def ccw'_def) hence False using distinct by (auto simp: psi_def ccw'_def) } moreover { assume c: "det3 t p q = 0" "det3 t q r > 0" "det3 t r p = 0" have "⋀x. det3 t q r = 0 ∨ t = x ∨ r = q ∨ q = x ∨ r = p ∨ p = x ∨ r = x" by (meson c(1) c(3) distinct four_points_aligned(1)) hence False by (metis (full_types) c(2) distinct less_irrefl) } moreover { assume c: "det3 t p q = 0" "det3 t q r = 0" "det3 t r p > 0" have "⋀x. det3 t r p = 0 ∨ t = x ∨ r = x ∨ q = x ∨ p = x" by (meson c(1) c(2) distinct four_points_aligned(1)) hence False by (metis (no_types) c(3) distinct less_numeral_extra(3)) } moreover { assume c: "ccw' t p q" "ccw' t q r" from ccw_two_up_contra[OF this ccws distinct] have False . } moreover { assume c: "ccw' t p q" "ccw' t r p" from ccw_two_up_contra[OF this(2,1), of s] ccws distinct have False by auto } moreover { assume c: "ccw' t q r" "ccw' t r p" from ccw_two_up_contra[OF this, of s] ccws distinct have False by auto } ultimately show "False" using ‹0 ≤ det3 t p q› ‹0 ≤ det3 t q r›‹0 ≤ det3 t r p› by (auto simp: less_eq_real_def ccw'_def) qed interpretation ccw: ccw_system ccw by unfold_locales (metis ccw_transitive_contr nondegenerate) lemma ccw_scaleR1: "det3 0 xr P ≠ 0 ⟹ 0 < e ⟹ ccw 0 xr P ⟹ ccw 0 (e*⇩Rxr) P" by (simp add: ccw_def) lemma ccw_scaleR2: "det3 0 xr P ≠ 0 ⟹ 0 < e ⟹ ccw 0 xr P ⟹ ccw 0 xr (e*⇩RP)" by (simp add: ccw_def) lemma ccw_translate3_aux: assumes "¬coll 0 a b" assumes "x < 1" assumes "ccw 0 (a - x*⇩Ra) (b - x *⇩R a)" shows "ccw 0 a b" proof - from assms have "¬ coll 0 (a - x*⇩Ra) (b - x *⇩R a)" by simp with assms have "ccw' 0 ((1 - x) *⇩R a) (b - x *⇩R a)" by (simp add: algebra_simps ccw_def) thus "ccw 0 a b" using ‹x < 1› by (simp add: ccw_def) qed lemma ccw_translate3_minus: "det3 0 a b ≠ 0 ⟹ x < 1 ⟹ ccw 0 a (b - x *⇩R a) ⟹ ccw 0 a b" using ccw_translate3_aux[of a b x] ccw_scaleR1[of a "b - x *⇩R a" "1-x" ] by (auto simp add: algebra_simps) lemma ccw_translate3: "det3 0 a b ≠ 0 ⟹ x < 1 ⟹ ccw 0 a b ⟹ ccw 0 a (x *⇩R a + b)" by (rule ccw_translate3_minus) (auto simp add: algebra_simps) lemma ccw_switch23: "det3 0 P Q ≠ 0 ⟹ (¬ ccw 0 Q P ⟷ ccw 0 P Q)" by (auto simp: ccw_def algebra_simps not_ccw'_eq ccw'_not_coll) lemma ccw0_upward: "fst a > 0 ⟹ snd a = 0 ⟹ snd b > snd a ⟹ ccw 0 a b" by (auto simp: ccw_def det3_def' algebra_simps ccw'_def) lemma ccw_uminus3[simp]: "det3 a b c ≠ 0 ⟹ ccw (-a) (-b) (-c) = ccw a b c" by (auto simp: ccw_def ccw'_def algebra_simps det3_def') lemma coll_minus_eq: "coll (x - a) (x - b) (x - c) = coll a b c" by (auto simp: det3_def' algebra_simps) lemma ccw_minus3: "¬ coll a b c ⟹ ccw (x - a) (x - b) (x - c) ⟷ ccw a b c" by (simp add: ccw_def coll_minus_eq) lemma ccw0_uminus[simp]: "¬ coll 0 a b ⟹ ccw 0 (-a) (-b) ⟷ ccw 0 a b" using ccw_uminus3[of 0 a b] by simp lemma lex_convex2: assumes "lex p q" "lex p r" "0 ≤ u" "u ≤ 1" shows "lex p (u *⇩R q + (1 - u) *⇩R r)" proof cases note ‹lex p q› also assume "lex q r" hence "lex q (u *⇩R q + (1 - u) *⇩R r)" using ‹0 ≤ u› ‹u ≤ 1› by (rule lex_convex_self2) finally (lex_trans) show ?thesis . next note ‹lex p r› also assume "¬ lex q r" hence "lex r q" by simp hence "lex r ((1 - u) *⇩R r + (1 - (1 - u)) *⇩R q)" using ‹0 ≤ u› ‹u ≤ 1› by (intro lex_convex_self2) simp_all finally (lex_trans) show ?thesis by (simp add: ac_simps) qed lemma lex_convex2': assumes "lex q p" "lex r p" "0 ≤ u" "u ≤ 1" shows "lex (u *⇩R q + (1 - u) *⇩R r) p" proof - have "lex (- p) (u *⇩R (-q) + (1 - u) *⇩R (-r))" using assms by (intro lex_convex2) (auto simp: lex_def) thus ?thesis by (auto simp: lex_def algebra_simps) qed lemma psi_convex1: assumes "psi c a b" assumes "psi d a b" assumes "0 ≤ u" "0 ≤ v" "u + v = 1" shows "psi (u *⇩R c + v *⇩R d) a b" proof - from assms have v: "v = (1 - u)" by simp show ?thesis using assms by (auto simp: psi_def v intro!: lex_convex2' lex_convex2) qed lemma psi_convex2: assumes "psi a c b" assumes "psi a d b" assumes "0 ≤ u" "0 ≤ v" "u + v = 1" shows "psi a (u *⇩R c + v *⇩R d) b" proof - from assms have v: "v = (1 - u)" by simp show ?thesis using assms by (auto simp: psi_def v intro!: lex_convex2' lex_convex2) qed lemma psi_convex3: assumes "psi a b c" assumes "psi a b d" assumes "0 ≤ u" "0 ≤ v" "u + v = 1" shows "psi a b (u *⇩R c + v *⇩R d)" proof - from assms have v: "v = (1 - u)" by simp show ?thesis using assms by (auto simp: psi_def v intro!: lex_convex2) qed lemma coll_convex: assumes "coll a b c" "coll a b d" assumes "0 ≤ u" "0 ≤ v" "u + v = 1" shows "coll a b (u *⇩R c + v *⇩R d)" proof cases assume "a ≠ b" with assms(1, 2) obtain x y where xy: "c - a = x *⇩R (b - a)" "d - a = y *⇩R (b - a)" by (auto simp: det3_translate_origin dest!: coll_scale) from assms have "(u + v) *⇩R a = a" by simp hence "u *⇩R c + v *⇩R d - a = u *⇩R (c - a) + v *⇩R (d - a)" by (simp add: algebra_simps) also have "… = u *⇩R x *⇩R (b - a) + v *⇩R y *⇩R (b - a)" by (simp add: xy) also have "… = (u * x + v * y) *⇩R (b - a)" by (simp add: algebra_simps) also have "coll 0 (b - a) …" by (simp add: coll_scaleR_right_eq) finally show ?thesis by (auto simp: det3_translate_origin) qed simp lemma (in ccw_vector_space) convex3: assumes "u ≥ 0" "v ≥ 0" "u + v = 1" "ccw a b d" "ccw a b c" shows "ccw a b (u *⇩R c + v *⇩R d)" proof - have "v = 1 - u" using assms by simp hence "ccw 0 (b - a) (u *⇩R (c - a) + v *⇩R (d - a))" using assms by (cases "u = 0" "v = 0" rule: bool.exhaust[case_product bool.exhaust]) (auto simp add: translate_origin intro!: add3) also have "(u + v) *⇩R a = a" by (simp add: assms) hence "u *⇩R (c - a) + v *⇩R (d - a) = u *⇩R c + v *⇩R d - a" by (auto simp: algebra_simps) finally show ?thesis by (simp add: translate_origin) qed lemma ccw_self[simp]: "ccw a a b" "ccw b a a" by (auto simp: ccw_def psi_def intro: cyclic) lemma ccw_sefl'[simp]: "ccw a b a" by (rule cyclic) simp lemma ccw_convex': assumes uv: "u ≥ 0" "v ≥ 0" "u + v = 1" assumes "ccw a b c" and 1: "coll a b c" assumes "ccw a b d" and 2: "¬ coll a b d" shows "ccw a b (u *⇩R c + v *⇩R d)" proof - from assms have u: "0 ≤ u" "u ≤ 1" and v: "v = 1 - u" by (auto simp: algebra_simps) let ?c = "u *⇩R c + v *⇩R d" from 1 have abd: "ccw' a b d" using assms by (auto simp: ccw_def) { assume 2: "¬ coll a b c" from 2 have "ccw' a b c" using assms by (auto simp: ccw_def) with abd have "ccw' a b ?c" using assms by (auto intro!: ccw'.convex3) hence ?thesis by (simp add: ccw_def) } moreover { assume 2: "coll a b c" { assume "a = b" hence ?thesis by simp } moreover { assume "v = 0" hence ?thesis by (auto simp: v assms) } moreover { assume "v ≠ 0" "a ≠ b" have "coll c a b" using 2 by (auto simp: det3_def' algebra_simps) from coll_ex_scaling[OF ‹a ≠ b› this] obtain r where c: "c = a + r *⇩R (b - a)" by auto have *: "u *⇩R (a + r *⇩R (b - a)) + v *⇩R d - a = (u * r) *⇩R (b - a) + (1 - u) *⇩R (d - a)" by (auto simp: algebra_simps v) have "ccw' a b ?c" using ‹v ≠ 0› uv abd by (simp add: ccw'.translate_origin c *) hence ?thesis by (simp add: ccw_def) } ultimately have ?thesis by blast } ultimately show ?thesis by blast qed lemma ccw_convex: assumes uv: "u ≥ 0" "v ≥ 0" "u + v = 1" assumes "ccw a b c" assumes "ccw a b d" assumes lex: "coll a b c ⟹ coll a b d ⟹ lex b a" shows "ccw a b (u *⇩R c + v *⇩R d)" proof - from assms have u: "0 ≤ u" "u ≤ 1" and v: "v = 1 - u" by (auto simp: algebra_simps) let ?c = "u *⇩R c + v *⇩R d" { assume coll: "coll a b c ∧ coll a b d" hence "coll a b ?c" by (auto intro!: coll_convex assms) moreover from coll have "psi a b c ∨ psi b c a ∨ psi c a b" "psi a b d ∨ psi b d a ∨ psi d a b" using assms by (auto simp add: ccw_def ccw'_not_coll) hence "psi a b ?c ∨ psi b ?c a ∨ psi ?c a b" using coll uv lex by (auto simp: psi_def ccw_def not_lex lexs_def v intro: lex_convex2 lex_convex2') ultimately have ?thesis by (simp add: ccw_def) } moreover { assume 1: "¬ coll a b d" and 2: "¬ coll a b c" from 1 have abd: "ccw' a b d" using assms by (auto simp: ccw_def) from 2 have "ccw' a b c" using assms by (auto simp: ccw_def) with abd have "ccw' a b ?c" using assms by (auto intro!: ccw'.convex3) hence ?thesis by (simp add: ccw_def) } moreover { assume "¬ coll a b d" "coll a b c" have ?thesis by (rule ccw_convex') fact+ } moreover { assume 1: "coll a b d" and 2: "¬ coll a b c" have "0 ≤ 1 - u" using assms by (auto ) from ccw_convex'[OF this ‹0 ≤ u› _ ‹ccw a b d› 1 ‹ccw a b c› 2] have ?thesis by (simp add: algebra_simps v) } ultimately show ?thesis by blast qed interpretation ccw: ccw_convex ccw S "λa b. lex b a" for S by unfold_locales (rule ccw_convex) lemma ccw_sorted_scaleR: "ccw.sortedP 0 xs ⟹ r > 0 ⟹ ccw.sortedP 0 (map ((*⇩R) r) xs)" by (induct xs) (auto intro!: ccw.sortedP.Cons ccw_scale23 elim!: ccw.sortedP_Cons simp del: scaleR_Pair) lemma ccw_sorted_implies_ccw'_sortedP: assumes nonaligned: "⋀y z. y ∈ set Ps ⟹ z ∈ set Ps ⟹ y ≠ z ⟹ ¬ coll 0 y z" assumes sorted: "linorder_list0.sortedP (ccw 0) Ps" assumes "distinct Ps" shows "linorder_list0.sortedP (ccw' 0 ) Ps" using assms proof (induction Ps) case (Cons P Ps) { fix p assume p: "p ∈ set Ps" moreover from p Cons.prems have "ccw 0 P p" by (auto elim!: linorder_list0.sortedP_Cons intro: Cons) ultimately have "ccw' 0 P p" using ‹distinct (P#Ps)› by (intro ccw_ncoll_imp_ccw Cons) auto } moreover have "linorder_list0.sortedP (ccw' 0) Ps" using Cons.prems by (intro Cons) (auto elim!: linorder_list0.sortedP_Cons intro: Cons) ultimately show ?case by (auto intro!: linorder_list0.Cons ) qed (auto intro: linorder_list0.Nil) end
section ‹Intersection› theory Intersection imports "HOL-Library.Monad_Syntax" Polygon Counterclockwise_2D_Arbitrary Affine_Form begin text ‹\label{sec:intersection}› subsection ‹Polygons and @{term ccw}, @{term lex}, @{term psi}, @{term coll}› lemma polychain_of_ccw_conjunction: assumes sorted: "ccw'.sortedP 0 Ps" assumes z: "z ∈ set (polychain_of Pc Ps)" shows "list_all (λ(xi, xj). ccw xi xj (fst z) ∧ ccw xi xj (snd z)) (polychain_of Pc Ps)" using assms proof (induction Ps arbitrary: Pc z rule: list.induct) case (Cons P Ps) { assume "set Ps = {}" hence ?case using Cons by simp } moreover { assume "set Ps ≠ {}" hence "Ps ≠ []" by simp { fix a assume "a ∈ set Ps" hence "ccw' 0 P a" using Cons.prems by (auto elim!: linorder_list0.sortedP_Cons) } note ccw' = this have sorted': "linorder_list0.sortedP (ccw' 0) Ps" using Cons.prems by (auto elim!: linorder_list0.sortedP_Cons) from in_set_polychain_of_imp_sum_list[OF Cons(3)] obtain d where d: "z = (Pc + sum_list (take d (P # Ps)), Pc + sum_list (take (Suc d) (P # Ps)))" . from Cons(3) have disj: "z = (Pc, Pc + P) ∨ z ∈ set (polychain_of (Pc + P) Ps)" by auto let ?th = "λ(xi, xj). ccw xi xj Pc ∧ ccw xi xj (Pc + P)" have la: "list_all ?th (polychain_of (Pc + P) Ps)" proof (rule list_allI) fix x assume x: "x ∈ set (polychain_of (Pc + P) Ps)" from in_set_polychain_of_imp_sum_list[OF this] obtain e where e: "x = (Pc + P + sum_list (take e Ps), Pc + P + sum_list (take (Suc e) Ps))" by auto { assume "e ≥ length Ps" hence "?th x" by (auto simp: e) } moreover { assume "e < length Ps" have 0: "⋀e. e < length Ps ⟹ ccw' 0 P (Ps ! e)" by (rule ccw') (simp add: ) have 2: "0 < e ⟹ ccw' 0 (P + sum_list (take e Ps)) (Ps ! e)" using ‹e < length Ps› by (auto intro!: ccw'.add1 0 ccw'.sum2 sorted' ccw'.sorted_nth_less simp: sum_list_sum_nth) have "ccw Pc (Pc + P + sum_list (take e Ps)) (Pc + P + sum_list (take (Suc e) Ps))" by (cases "e = 0") (auto simp add: ccw_translate_origin take_Suc_eq add.assoc[symmetric] 0 2 intro!: ccw'_imp_ccw intro: cyclic) hence "ccw (Pc + P + sum_list (take e Ps)) (Pc + P + sum_list (take (Suc e) Ps)) Pc" by (rule cyclic) moreover have "0 < e ⟹ ccw 0 (Ps ! e) (- sum_list (take e Ps))" using ‹e < length Ps› by (auto simp add: take_Suc_eq add.assoc[symmetric] sum_list_sum_nth intro!: ccw'_imp_ccw ccw'.sum2 sorted' ccw'.sorted_nth_less) hence "ccw (Pc + P + sum_list (take e Ps)) (Pc + P + sum_list (take (Suc e) Ps)) (Pc + P)" by (cases "e = 0") (simp_all add: ccw_translate_origin take_Suc_eq) ultimately have "?th x" by (auto simp add: e) } ultimately show "?th x" by arith qed from disj have ?case proof assume z: "z ∈ set (polychain_of (Pc + P) Ps)" have "ccw 0 P (sum_list (take d (P # Ps)))" proof (cases d) case (Suc e) note e = this show ?thesis proof (cases e) case (Suc f) have "ccw 0 P (P + sum_list (take (Suc f) Ps))" using z by (force simp add: sum_list_sum_nth intro!: ccw'.sum intro: ccw' ccw'_imp_ccw) thus ?thesis by (simp add: e Suc) qed (simp add: e) qed simp hence "ccw Pc (Pc + P) (fst z)" by (simp add: d ccw_translate_origin) moreover from z have "ccw 0 P (P + sum_list (take d Ps))" by (cases d, force) (force simp add: sum_list_sum_nth intro!: ccw'_imp_ccw ccw'.sum intro: ccw')+ hence "ccw Pc (Pc + P) (snd z)" by (simp add: d ccw_translate_origin) moreover from z Cons.prems have "list_all (λ(xi, xj). ccw xi xj (fst z) ∧ ccw xi xj (snd z)) (polychain_of (Pc + P) Ps)" by (intro Cons.IH) (auto elim!: linorder_list0.sortedP_Cons) ultimately show ?thesis by simp qed (simp add: la) } ultimately show ?case by blast qed simp lemma lex_polychain_of_center: "d ∈ set (polychain_of x0 xs) ⟹ list_all (λx. lex x 0) xs ⟹ lex (snd d) x0" proof (induction xs arbitrary: x0) case (Cons x xs) thus ?case by (auto simp add: lex_def lex_translate_origin dest!: Cons.IH) qed (auto simp: lex_translate_origin) lemma lex_polychain_of_last: "(c, d) ∈ set (polychain_of x0 xs) ⟹ list_all (λx. lex x 0) xs ⟹ lex (snd (last (polychain_of x0 xs))) d" proof (induction xs arbitrary: x0 c d) case (Cons x xs) let ?c1 = "c = x0 ∧ d = x0 + x" let ?c2 = "(c, d) ∈ set (polychain_of (x0 + x) xs)" from Cons(2) have "?c1 ∨ ?c2" by auto thus ?case proof assume ?c1 with Cons.prems show ?thesis by (auto intro!: lex_polychain_of_center) next assume ?c2 from Cons.IH[OF this] Cons.prems show ?thesis by auto qed qed (auto simp: lex_translate_origin) lemma distinct_fst_polychain_of: assumes "list_all (λx. x ≠ 0) xs" assumes "list_all (λx. lex x 0) xs" shows "distinct (map fst (polychain_of x0 xs))" using assms proof (induction xs arbitrary: x0) case Nil thus ?case by simp next case (Cons x xs) hence "⋀d. list_all (λx. lex x 0) (x # take d xs)" by (auto simp: list_all_iff dest!: in_set_takeD) from sum_list_nlex_eq_zero_iff[OF this] Cons.prems show ?case by (cases "xs = []") (auto intro!: Cons.IH elim!: in_set_polychain_of_imp_sum_list) qed lemma distinct_snd_polychain_of: assumes "list_all (λx. x ≠ 0) xs" assumes "list_all (λx. lex x 0) xs" shows "distinct (map snd (polychain_of x0 xs))" using assms proof (induction xs arbitrary: x0) case Nil thus ?case by simp next case (Cons x xs) have contra: "⋀d. xs ≠ [] ⟹ list_all (λx. x ≠ 0) xs ⟹ list_all ((=) 0) (take (Suc d) xs) ⟹ False" by (auto simp: neq_Nil_conv) from Cons have "⋀d. list_all (λx. lex x 0) (take (Suc d) xs)" by (auto simp: list_all_iff dest!: in_set_takeD) from sum_list_nlex_eq_zero_iff[OF this] Cons.prems contra show ?case by (cases "xs = []") (auto intro!: Cons.IH elim!: in_set_polychain_of_imp_sum_list dest!: contra) qed subsection ‹Orient all entries› lift_definition nlex_pdevs::"point pdevs ⇒ point pdevs" is "λx n. if lex 0 (x n) then - x n else x n" by simp lemma pdevs_apply_nlex_pdevs[simp]: "pdevs_apply (nlex_pdevs x) n = (if lex 0 (pdevs_apply x n) then - pdevs_apply x n else pdevs_apply x n)" by transfer simp lemma nlex_pdevs_zero_pdevs[simp]: "nlex_pdevs zero_pdevs = zero_pdevs" by (auto intro!: pdevs_eqI) lemma pdevs_domain_nlex_pdevs[simp]: "pdevs_domain (nlex_pdevs x) = pdevs_domain x" by (auto simp: pdevs_domain_def) lemma degree_nlex_pdevs[simp]: "degree (nlex_pdevs x) = degree x" by (rule degree_cong) auto lemma pdevs_val_nlex_pdevs: assumes "e ∈ UNIV → I" "uminus ` I = I" obtains e' where "e' ∈ UNIV → I" "pdevs_val e x = pdevs_val e' (nlex_pdevs x)" using assms by (atomize_elim, intro exI[where x="λn. if lex 0 (pdevs_apply x n) then - e n else e n"]) (force simp: pdevs_val_pdevs_domain intro!: sum.cong) lemma pdevs_val_nlex_pdevs2: assumes "e ∈ UNIV → I" "uminus ` I = I" obtains e' where "e' ∈ UNIV → I" "pdevs_val e (nlex_pdevs x) = pdevs_val e' x" using assms by (atomize_elim, intro exI[where x="λn. (if lex 0 (pdevs_apply x n) then - e n else e n)"]) (force simp: pdevs_val_pdevs_domain intro!: sum.cong) lemma pdevs_val_selsort_ccw: assumes "distinct xs" assumes "e ∈ UNIV → I" obtains e' where "e' ∈ UNIV → I" "pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list (ccw.selsort 0 xs))" proof - have "set xs = set (ccw.selsort 0 xs)" "distinct xs" "distinct (ccw.selsort 0 xs)" by (simp_all add: assms) from this assms(2) obtain e' where "e' ∈ UNIV → I" "pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list (ccw.selsort 0 xs))" by (rule pdevs_val_permute) thus thesis .. qed lemma pdevs_val_selsort_ccw2: assumes "distinct xs" assumes "e ∈ UNIV → I" obtains e' where "e' ∈ UNIV → I" "pdevs_val e (pdevs_of_list (ccw.selsort 0 xs)) = pdevs_val e' (pdevs_of_list xs)" proof - have "set (ccw.selsort 0 xs) = set xs" "distinct (ccw.selsort 0 xs)" "distinct xs" by (simp_all add: assms) from this assms(2) obtain e' where "e' ∈ UNIV → I" "pdevs_val e (pdevs_of_list (ccw.selsort 0 xs)) = pdevs_val e' (pdevs_of_list xs)" by (rule pdevs_val_permute) thus thesis .. qed lemma lex_nlex_pdevs: "lex (pdevs_apply (nlex_pdevs x) i) 0" by (auto simp: lex_def algebra_simps prod_eq_iff) subsection ‹Lowest Vertex› definition lowest_vertex::"'a::ordered_euclidean_space aform ⇒ 'a" where "lowest_vertex X = fst X - sum_list (map snd (list_of_pdevs (snd X)))" lemma snd_abs: "snd (abs x) = abs (snd x)" by (metis abs_prod_def snd_conv) lemma lowest_vertex: fixes X Y::"(real*real) aform" assumes "e ∈ UNIV → {-1 .. 1}" assumes "⋀i. snd (pdevs_apply (snd X) i) ≥ 0" assumes "⋀i. abs (snd (pdevs_apply (snd Y) i)) = abs (snd (pdevs_apply (snd X) i))" assumes "degree_aform Y = degree_aform X" assumes "fst Y = fst X" shows "snd (lowest_vertex X) ≤ snd (aform_val e Y)" proof - from abs_pdevs_val_le_tdev[OF assms(1), of "snd Y"] have "snd ¦pdevs_val e (snd Y)¦ ≤ (∑i<degree_aform Y. ¦snd (pdevs_apply (snd X) i)¦)" unfolding lowest_vertex_def by (auto simp: aform_val_def tdev_def less_eq_prod_def snd_sum snd_abs assms) also have "… = (∑i<degree_aform X. snd (pdevs_apply (snd X) i))" by (simp add: assms) also have "… ≤ snd (sum_list (map snd (list_of_pdevs (snd X))))" by (simp add: sum_list_list_of_pdevs dense_list_of_pdevs_def sum_list_distinct_conv_sum_set snd_sum atLeast0LessThan) finally show ?thesis by (auto simp: aform_val_def lowest_vertex_def minus_le_iff snd_abs abs_real_def assms split: if_split_asm) qed lemma sum_list_nonposI: fixes xs::"'a::ordered_comm_monoid_add list" shows "list_all (λx. x ≤ 0) xs ⟹ sum_list xs ≤ 0" by (induct xs) (auto simp: intro!: add_nonpos_nonpos) lemma center_le_lowest: "fst (fst X) ≤ fst (lowest_vertex (fst X, nlex_pdevs (snd X)))" by (auto simp: lowest_vertex_def fst_sum_list intro!: sum_list_nonposI) (auto simp: lex_def list_all_iff list_of_pdevs_def dest!: in_set_butlastD split: if_split_asm) lemma lowest_vertex_eq_center_iff: "lowest_vertex (x0, nlex_pdevs (snd X)) = x0 ⟷ snd X = zero_pdevs" proof assume "lowest_vertex (x0, nlex_pdevs (snd X)) = x0" then have "sum_list (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = 0" by (simp add: lowest_vertex_def) moreover have "list_all (λx. Counterclockwise_2D_Arbitrary.lex x 0) (map snd (list_of_pdevs (nlex_pdevs (snd X))))" by (auto simp add: list_all_iff list_of_pdevs_def) ultimately have "∀x∈set (list_of_pdevs (nlex_pdevs (snd X))). snd x = 0" by (simp add: sum_list_nlex_eq_zero_iff list_all_iff) then have "pdevs_apply (snd X) i = pdevs_apply zero_pdevs i" for i by (simp add: list_of_pdevs_def split: if_splits) then show "snd X = zero_pdevs" by (rule pdevs_eqI) qed (simp add: lowest_vertex_def) subsection ‹Collinear Generators› lemma scaleR_le_self_cancel: fixes c::"'a::ordered_real_vector" shows "a *⇩R c ≤ c ⟷ (1 < a ∧ c ≤ 0 ∨ a < 1 ∧ 0 ≤ c ∨ a = 1)" using scaleR_le_0_iff[of "a - 1" c] by (simp add: algebra_simps) lemma pdevs_val_coll: assumes coll: "list_all (coll 0 x) xs" assumes nlex: "list_all (λx. lex x 0) xs" assumes "x ≠ 0" assumes "f ∈ UNIV → {-1 .. 1}" obtains e where "e ∈ {-1 .. 1}" "pdevs_val f (pdevs_of_list xs) = e *⇩R (sum_list xs)" proof cases assume "sum_list xs = 0" have "pdevs_of_list xs = zero_pdevs" by (auto intro!: pdevs_eqI sum_list_nlex_eq_zeroI[OF nlex ‹sum_list xs = 0›] simp: pdevs_apply_pdevs_of_list list_all_iff dest!: nth_mem) hence "0 ∈ {-1 .. 1::real}" "pdevs_val f (pdevs_of_list xs) = 0 *⇩R sum_list xs" by simp_all thus ?thesis .. next assume "sum_list xs ≠ 0" have "sum_list (map abs xs) ≥ 0" by (auto intro!: sum_list_nonneg) hence [simp]: "¬sum_list (map abs xs) ≤ 0" by (metis ‹sum_list xs ≠ 0› abs_le_zero_iff antisym_conv sum_list_abs) have collist: "list_all (coll 0 (sum_list xs)) xs" proof (rule list_allI) fix y assume "y ∈ set xs" hence "coll 0 x y" using coll by (auto simp: list_all_iff) also have "coll 0 x (sum_list xs)" using coll by (auto simp: list_all_iff intro!: coll_sum_list) finally (coll_trans) show "coll 0 (sum_list xs) y" by (simp add: coll_commute ‹x ≠ 0›) qed { fix i assume "i < length xs" hence "∃r. xs ! i = r *⇩R (sum_list xs)" by (metis (mono_tags) coll_scale nth_mem ‹sum_list xs ≠ 0› list_all_iff collist) } then obtain r where r: "⋀i. i < length xs ⟹ (xs ! i) = r i *⇩R (sum_list xs)" by metis let ?coll = "pdevs_of_list xs" have "pdevs_val f (pdevs_of_list xs) = (∑i<degree (pdevs_of_list xs). f i *⇩R xs ! i)" unfolding pdevs_val_sum by (simp add: pdevs_apply_pdevs_of_list less_degree_pdevs_of_list_imp_less_length) also have "… = (∑i<degree ?coll. (f i * r i) *⇩R (sum_list xs))" by (simp add: r less_degree_pdevs_of_list_imp_less_length) also have "… = (∑i<degree ?coll. f i * r i) *⇩R (sum_list xs)" by (simp add: algebra_simps scaleR_sum_left) finally have eq: "pdevs_val f ?coll = (∑i<degree ?coll. f i * r i) *⇩R (sum_list xs)" (is "_ = ?e *⇩R _") . have "abs (pdevs_val f ?coll) ≤ tdev ?coll" using assms(4) by (intro abs_pdevs_val_le_tdev) (auto simp: Pi_iff less_imp_le) also have "… = sum_list (map abs xs)" using assms by simp also note eq finally have less: "¦?e¦ *⇩R abs (sum_list xs) ≤ sum_list (map abs xs)" by (simp add: abs_scaleR) also have "¦sum_list xs¦ = sum_list (map abs xs)" using coll ‹x ≠ 0› nlex by (rule abs_sum_list_coll) finally have "?e ∈ {-1 .. 1}" by (auto simp add: less_le scaleR_le_self_cancel) thus ?thesis using eq .. qed lemma scaleR_eq_self_cancel: fixes x::"'a::real_vector" shows "a *⇩R x = x ⟷ a = 1 ∨ x = 0" using scaleR_cancel_right[of a x 1] by simp lemma abs_pdevs_val_less_tdev: assumes "e ∈ UNIV → {-1 <..< 1}" "degree x > 0" shows "¦pdevs_val e x¦ < tdev x" proof - have bnds: "⋀i. ¦e i¦ < 1" "⋀i. ¦e i¦ ≤ 1" using assms by (auto simp: Pi_iff abs_less_iff order.strict_implies_order) moreover let ?w = "degree x - 1" have witness: "¦e ?w¦ *⇩R ¦pdevs_apply x ?w¦ < ¦pdevs_apply x ?w¦" using degree_least_nonzero[of x] assms bnds by (intro neq_le_trans) (auto simp: scaleR_eq_self_cancel Pi_iff intro!: scaleR_left_le_one_le neq_le_trans intro: abs_leI less_imp_le dest!: order.strict_implies_not_eq) ultimately show ?thesis using assms witness bnds by (auto simp: pdevs_val_sum tdev_def abs_scaleR intro!: le_less_trans[OF sum_abs] sum_strict_mono_ex1 scaleR_left_le_one_le) qed lemma pdevs_val_coll_strict: assumes coll: "list_all (coll 0 x) xs" assumes nlex: "list_all (λx. lex x 0) xs" assumes "x ≠ 0" assumes "f ∈ UNIV → {-1 <..< 1}" obtains e where "e ∈ {-1 <..< 1}" "pdevs_val f (pdevs_of_list xs) = e *⇩R (sum_list xs)" proof cases assume "sum_list xs = 0" have "pdevs_of_list xs = zero_pdevs" by (auto intro!: pdevs_eqI sum_list_nlex_eq_zeroI[OF nlex ‹sum_list xs = 0›] simp: pdevs_apply_pdevs_of_list list_all_iff dest!: nth_mem) hence "0 ∈ {-1 <..< 1::real}" "pdevs_val f (pdevs_of_list xs) = 0 *⇩R sum_list xs" by simp_all thus ?thesis .. next assume "sum_list xs ≠ 0" have "sum_list (map abs xs) ≥ 0" by (auto intro!: sum_list_nonneg) hence [simp]: "¬sum_list (map abs xs) ≤ 0" by (metis ‹sum_list xs ≠ 0› abs_le_zero_iff antisym_conv sum_list_abs) have "∃x ∈ set xs. x ≠ 0" proof (rule ccontr) assume "¬ (∃x∈set xs. x ≠ 0)" hence "⋀x. x ∈ set xs ⟹ x = 0" by auto hence "sum_list xs = 0" by (auto simp: sum_list_eq_0_iff_nonpos list_all_iff less_eq_prod_def prod_eq_iff fst_sum_list snd_sum_list) thus False using ‹sum_list xs ≠ 0› by simp qed then obtain i where i: "i < length xs" "xs ! i ≠ 0" by (metis in_set_conv_nth) hence "i < degree (pdevs_of_list xs)" by (auto intro!: degree_gt simp: pdevs_apply_pdevs_of_list) hence deg_pos: "0 < degree (pdevs_of_list xs)" by simp have collist: "list_all (coll 0 (sum_list xs)) xs" proof (rule list_allI) fix y assume "y ∈ set xs" hence "coll 0 x y" using coll by (auto simp: list_all_iff) also have "coll 0 x (sum_list xs)" using coll by (auto simp: list_all_iff intro!: coll_sum_list) finally (coll_trans) show "coll 0 (sum_list xs) y" by (simp add: coll_commute ‹x ≠ 0›) qed { fix i assume "i < length xs" hence "∃r. xs ! i = r *⇩R (sum_list xs)" by (metis (mono_tags, lifting) ‹sum_list xs ≠ 0› coll_scale collist list_all_iff nth_mem) } then obtain r where r: "⋀i. i < length xs ⟹ (xs ! i) = r i *⇩R (sum_list xs)" by metis let ?coll = "pdevs_of_list xs" have "pdevs_val f (pdevs_of_list xs) = (∑i<degree (pdevs_of_list xs). f i *⇩R xs ! i)" unfolding pdevs_val_sum by (simp add: less_degree_pdevs_of_list_imp_less_length pdevs_apply_pdevs_of_list) also have "… = (∑i<degree ?coll. (f i * r i) *⇩R (sum_list xs))" by (simp add: r less_degree_pdevs_of_list_imp_less_length) also have "… = (∑i<degree ?coll. f i * r i) *⇩R (sum_list xs)" by (simp add: algebra_simps scaleR_sum_left) finally have eq: "pdevs_val f ?coll = (∑i<degree ?coll. f i * r i) *⇩R (sum_list xs)" (is "_ = ?e *⇩R _") . have "abs (pdevs_val f ?coll) < tdev ?coll" using assms(4) by (intro abs_pdevs_val_less_tdev) (auto simp: Pi_iff less_imp_le deg_pos) also have "… = sum_list (map abs xs)" using assms by simp also note eq finally have less: "¦?e¦ *⇩R abs (sum_list xs) < sum_list (map abs xs)" by (simp add: abs_scaleR) also have "¦sum_list xs¦ = sum_list (map abs xs)" using coll ‹x ≠ 0› nlex by (rule abs_sum_list_coll) finally have "?e ∈ {-1 <..< 1}" by (auto simp add: less_le scaleR_le_self_cancel) thus ?thesis using eq .. qed subsection ‹Independent Generators› fun independent_pdevs::"point list ⇒ point list" where "independent_pdevs [] = []" | "independent_pdevs (x#xs) = (let (cs, is) = List.partition (coll 0 x) xs; s = x + sum_list cs in (if s = 0 then [] else [s]) @ independent_pdevs is)" lemma in_set_independent_pdevsE: assumes "y ∈ set (independent_pdevs xs)" obtains x where "x∈set xs" "coll 0 x y" proof atomize_elim show "∃x. x ∈ set xs ∧ coll 0 x y" using assms proof (induct xs rule: independent_pdevs.induct) case 1 thus ?case by simp next case (2 z zs) let ?c1 = "y = z + sum_list (filter (coll 0 z) zs)" let ?c2 = "y ∈ set (independent_pdevs (filter (Not ∘ coll 0 z) zs))" from 2 have "?c1 ∨ ?c2" by (auto simp: Let_def split: if_split_asm) thus ?case proof assume ?c2 hence "y ∈ set (independent_pdevs (snd (partition (coll 0 z) zs)))" by simp from 2(1)[OF refl prod.collapse refl this] show ?case by auto next assume y: ?c1 show ?case unfolding y by (rule exI[where x="z"]) (auto intro!: coll_add coll_sum_list ) qed qed qed lemma in_set_independent_pdevs_nonzero: "x ∈ set (independent_pdevs xs) ⟹ x ≠ 0" proof (induct xs rule: independent_pdevs.induct) case (2 y ys) from 2(1)[OF refl prod.collapse refl] 2(2) show ?case by (auto simp: Let_def split: if_split_asm) qed simp lemma independent_pdevs_pairwise_non_coll: assumes "x ∈ set (independent_pdevs xs)" assumes "y ∈ set (independent_pdevs xs)" assumes "⋀x. x ∈ set xs ⟹ x ≠ 0" assumes "x ≠ y" shows "¬ coll 0 x y" using assms proof (induct xs rule: independent_pdevs.induct) case 1 thus ?case by simp next case (2 z zs) from 2 have "z ≠ 0" by simp from 2(2) have "x ≠ 0" by (rule in_set_independent_pdevs_nonzero) from 2(3) have "y ≠ 0" by (rule in_set_independent_pdevs_nonzero) let ?c = "filter (coll 0 z) zs" let ?nc = "filter (Not ∘ coll 0 z) zs" { assume "x ∈ set (independent_pdevs ?nc)" "y ∈ set (independent_pdevs ?nc)" hence "¬coll 0 x y" by (intro 2(1)[OF refl prod.collapse refl _ _ 2(4) 2(5)]) auto } note IH = this { fix x assume "x ≠ 0" "z + sum_list ?c ≠ 0" "coll 0 x (z + sum_list ?c)" hence "x ∉ set (independent_pdevs ?nc)" using sum_list_filter_coll_ex_scale[OF ‹z ≠ 0›, of "z#zs"] by (auto elim!: in_set_independent_pdevsE simp: coll_commute) (metis (no_types) ‹x ≠ 0› coll_scale coll_scaleR) } note nc = this from 2(2,3,4,5) nc[OF ‹x ≠ 0›] nc[OF ‹y ≠ 0›] show ?case by (auto simp: Let_def IH coll_commute split: if_split_asm) qed lemma distinct_independent_pdevs[simp]: shows "distinct (independent_pdevs xs)" proof (induct xs rule: independent_pdevs.induct) case 1 thus ?case by simp next case (2 x xs) let ?is = "independent_pdevs (filter (Not ∘ coll 0 x) xs)" have "distinct ?is" by (rule 2) (auto intro!: 2) thus ?case proof (clarsimp simp add: Let_def) let ?s = "x + sum_list (filter (coll 0 x) xs)" assume s: "?s ≠ 0" "?s ∈ set ?is" from in_set_independent_pdevsE[OF s(2)] obtain y where y: "y ∈ set (filter (Not ∘ coll 0 x) xs)" "coll 0 y (x + sum_list (filter (coll 0 x) xs))" by auto { assume "y = 0 ∨ x = 0 ∨ sum_list (filter (coll 0 x) xs) = 0" hence False using s y by (auto simp: coll_commute) } moreover { assume "y ≠ 0" "x ≠ 0" "sum_list (filter (coll 0 x) xs) ≠ 0" "sum_list (filter (coll 0 x) xs) + x ≠ 0" have *: "coll 0 (sum_list (filter (coll 0 x) xs)) x" by (auto intro!: coll_sum_list simp: coll_commute) have "coll 0 y (sum_list (filter (coll 0 x) xs) + x)" using s y by (simp add: add.commute) hence "coll 0 y x" using * by (rule coll_add_trans) fact+ hence False using s y by (simp add: coll_commute) } ultimately show False using s y by (auto simp: add.commute) qed qed lemma in_set_independent_pdevs_invariant_nlex: "x ∈ set (independent_pdevs xs) ⟹ (⋀x. x ∈ set xs ⟹ lex x 0) ⟹ (⋀x. x ∈ set xs ⟹ x ≠ 0) ⟹ Counterclockwise_2D_Arbitrary.lex x 0" proof (induction xs arbitrary: x rule: independent_pdevs.induct ) case 1 thus ?case by simp next case (2 y ys) from 2 have "y ≠ 0" by auto from 2(2) have "x ∈ set (independent_pdevs (filter (Not ∘ coll 0 y) ys)) ∨ x = y + sum_list (filter (coll 0 y) ys)" by (auto simp: Let_def split: if_split_asm) thus ?case proof assume "x ∈ set (independent_pdevs (filter (Not ∘ coll 0 y) ys))" from 2(1)[OF refl prod.collapse refl, simplified, OF this 2(3,4)] show ?case by simp next assume "x = y + sum_list (filter (coll 0 y) ys)" also have "lex … 0" by (force intro: nlex_add nlex_sum simp: sum_list_sum_nth dest: nth_mem intro: 2(3)) finally show ?case . qed qed lemma pdevs_val_independent_pdevs2: assumes "e ∈ UNIV → I" shows "∃e'. e' ∈ UNIV → I ∧ pdevs_val e (pdevs_of_list (independent_pdevs xs)) = pdevs_val e' (pdevs_of_list xs)" using assms proof (induct xs arbitrary: e rule: independent_pdevs.induct) case 1 thus ?case by force next case (2 x xs) let ?coll = "(filter (coll 0 x) (x#xs))" let ?ncoll = "(filter (Not o coll 0 x) (x#xs))" let ?e0 = "if sum_list ?coll = 0 then e else e ∘ (+) (Suc 0)" have "pdevs_val e (pdevs_of_list (independent_pdevs (x#xs))) = e 0 *⇩R (sum_list ?coll) + pdevs_val ?e0 (pdevs_of_list (independent_pdevs ?ncoll))" (is "_ = ?vc + ?vnc") by (simp add: Let_def) also have e_split: "(λ_. e 0) ∈ UNIV → I" "?e0 ∈ UNIV → I" using 2(2) by auto from 2(1)[OF refl prod.collapse refl e_split(2)] obtain e' where e': "e' ∈ UNIV → I" and "?vnc = pdevs_val e' (pdevs_of_list ?ncoll)" by (auto simp add: o_def) note this(2) also have "?vc = pdevs_val (λ_. e 0) (pdevs_of_list ?coll)" by (simp add: pdevs_val_const_pdevs_of_list) also from pdevs_val_pdevs_of_list_append[OF e_split(1) e'] obtain e'' where e'': "e'' ∈ UNIV → I" and "pdevs_val (λ_. e 0) (pdevs_of_list ?coll) + pdevs_val e' (pdevs_of_list ?ncoll) = pdevs_val e'' (pdevs_of_list (?coll @ ?ncoll))" by metis note this(2) also from pdevs_val_perm[OF partition_permI e'', of "coll 0 x" "x#xs"] obtain e''' where e''': "e''' ∈ UNIV → I" and "… = pdevs_val e''' (pdevs_of_list (x # xs))" by metis note this(2) finally show ?case using e''' by auto qed lemma list_all_filter: "list_all p (filter p xs)" by (induct xs) auto lemma pdevs_val_independent_pdevs: assumes "list_all (λx. lex x 0) xs" assumes "list_all (λx. x ≠ 0) xs" assumes "e ∈ UNIV → {-1 .. 1}" shows "∃e'. e' ∈ UNIV → {-1 .. 1} ∧ pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list (independent_pdevs xs))" using assms(1,2,3) proof (induct xs arbitrary: e rule: independent_pdevs.induct) case 1 thus ?case by force next case (2 x xs) let ?coll = "(filter (coll 0 x) (x#xs))" let ?ncoll = "(filter (Not o coll 0 x) xs)" from 2 have "x ≠ 0" by simp from pdevs_val_partition[OF 2(4), of "x#xs" "coll 0 x"] obtain f g where part: "pdevs_val e (pdevs_of_list (x # xs)) = pdevs_val f (pdevs_of_list ?coll) + pdevs_val g (pdevs_of_list (filter (Not o coll 0 x) (x#xs)))" and f: "f ∈ UNIV → {-1 .. 1}" and g: "g ∈ UNIV → {-1 .. 1}" by blast note part also have "list_all (λx. lex x 0) (filter (coll 0 x) (x#xs))" using 2(2) by (auto simp: inner_prod_def list_all_iff) from pdevs_val_coll[OF list_all_filter this ‹x ≠ 0› f] obtain f' where "pdevs_val f (pdevs_of_list ?coll) = f' *⇩R sum_list (filter (coll 0 x) (x#xs))" and f': "f' ∈ {-1 .. 1}" by blast note this(1) also have "filter (Not o coll 0 x) (x#xs) = ?ncoll" by simp also from 2(2) have "list_all (λx. lex x 0) ?ncoll" "list_all (λx. x ≠ 0) ?ncoll" by (auto simp: list_all_iff) from 2(1)[OF refl partition_filter_conv[symmetric] refl this g] obtain g' where "pdevs_val g (pdevs_of_list ?ncoll) = pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))" and g': "g' ∈ UNIV → {-1 .. 1}" by metis note this(1) also define h where "h = (if sum_list ?coll ≠ 0 then rec_nat f' (λi _. g' i) else g')" have "f' *⇩R sum_list ?coll + pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll)) = pdevs_val h (pdevs_of_list (independent_pdevs (x#xs)))" by (simp add: h_def o_def Let_def) finally have "pdevs_val e (pdevs_of_list (x # xs)) = pdevs_val h (pdevs_of_list (independent_pdevs (x # xs)))" . moreover have "h ∈ UNIV → {-1 .. 1}" proof fix i show "h i ∈ {-1 .. 1}" using f' g' by (cases i) (auto simp: h_def) qed ultimately show ?case by blast qed lemma pdevs_val_independent_pdevs_strict: assumes "list_all (λx. lex x 0) xs" assumes "list_all (λx. x ≠ 0) xs" assumes "e ∈ UNIV → {-1 <..< 1}" shows "∃e'. e' ∈ UNIV → {-1 <..< 1} ∧ pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list (independent_pdevs xs))" using assms(1,2,3) proof (induct xs arbitrary: e rule: independent_pdevs.induct) case 1 thus ?case by force next case (2 x xs) let ?coll = "(filter (coll 0 x) (x#xs))" let ?ncoll = "(filter (Not o coll 0 x) xs)" from 2 have "x ≠ 0" by simp from pdevs_val_partition[OF 2(4), of "x#xs" "coll 0 x"] obtain f g where part: "pdevs_val e (pdevs_of_list (x # xs)) = pdevs_val f (pdevs_of_list ?coll) + pdevs_val g (pdevs_of_list (filter (Not o coll 0 x) (x#xs)))" and f: "f ∈ UNIV → {-1 <..< 1}" and g: "g ∈ UNIV → {-1 <..< 1}" by blast note part also have "list_all (λx. lex x 0) (filter (coll 0 x) (x#xs))" using 2(2) by (auto simp: inner_prod_def list_all_iff) from pdevs_val_coll_strict[OF list_all_filter this ‹x ≠ 0› f] obtain f' where "pdevs_val f (pdevs_of_list ?coll) = f' *⇩R sum_list (filter (coll 0 x) (x#xs))" and f': "f' ∈ {-1 <..< 1}" by blast note this(1) also have "filter (Not o coll 0 x) (x#xs) = ?ncoll" by simp also from 2(2) have "list_all (λx. lex x 0) ?ncoll" "list_all (λx. x ≠ 0) ?ncoll" by (auto simp: list_all_iff) from 2(1)[OF refl partition_filter_conv[symmetric] refl this g] obtain g' where "pdevs_val g (pdevs_of_list ?ncoll) = pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))" and g': "g' ∈ UNIV → {-1 <..< 1}" by metis note this(1) also define h where "h = (if sum_list ?coll ≠ 0 then rec_nat f' (λi _. g' i) else g')" have "f' *⇩R sum_list ?coll + pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll)) = pdevs_val h (pdevs_of_list (independent_pdevs (x#xs)))" by (simp add: h_def o_def Let_def) finally have "pdevs_val e (pdevs_of_list (x # xs)) = pdevs_val h (pdevs_of_list (independent_pdevs (x # xs)))" . moreover have "h ∈ UNIV → {-1 <..< 1}" proof fix i show "h i ∈ {-1 <..< 1}" using f' g' by (cases i) (auto simp: h_def) qed ultimately show ?case by blast qed lemma sum_list_independent_pdevs: "sum_list (independent_pdevs xs) = sum_list xs" proof (induct xs rule: independent_pdevs.induct) case (2 y ys) from 2[OF refl prod.collapse refl] show ?case using sum_list_partition[of "coll 0 y" ys, symmetric] by (auto simp: Let_def) qed simp lemma independent_pdevs_eq_Nil_iff: "list_all (λx. lex x 0) xs ⟹ list_all (λx. x ≠ 0) xs ⟹ independent_pdevs xs = [] ⟷ xs = []" proof (induct xs) case Nil thus ?case by simp next case (Cons x xs) from Cons(2) have "list_all (λx. lex x 0) (x # filter (coll 0 x) xs)" by (auto simp: list_all_iff) from sum_list_nlex_eq_zero_iff[OF this] Cons(3) show ?case by (auto simp: list_all_iff) qed subsection ‹Independent Oriented Generators› definition "inl p = independent_pdevs (map snd (list_of_pdevs (nlex_pdevs p)))" lemma distinct_inl[simp]: "distinct (inl (snd X))" by (auto simp: inl_def) lemma in_set_inl_nonzero: "x ∈ set (inl xs) ⟹ x ≠ 0" by (auto simp: inl_def in_set_independent_pdevs_nonzero) lemma inl_ncoll: "y ∈ set (inl (snd X)) ⟹ z ∈ set (inl (snd X)) ⟹ y ≠ z ⟹ ¬coll 0 y z" unfolding inl_def by (rule independent_pdevs_pairwise_non_coll, assumption+) (auto simp: inl_def list_of_pdevs_nonzero) lemma in_set_inl_lex: "x ∈ set (inl xs) ⟹ lex x 0" by (auto simp: inl_def list_of_pdevs_def dest!: in_set_independent_pdevs_invariant_nlex split: if_split_asm) interpretation ccw0: linorder_list "ccw 0" "set (inl (snd X))" proof unfold_locales fix a b c show "a ≠ b ⟹ ccw 0 a b ∨ ccw 0 b a" by (metis UNIV_I ccw_self(1) nondegenerate) assume a: "a ∈ set (inl (snd X))" show "ccw 0 a a" by simp assume b: "b ∈ set (inl (snd X))" show "ccw 0 a b ⟹ ccw 0 b a ⟹ a = b" by (metis ccw_self(1) in_set_inl_nonzero mem_Collect_eq not_ccw_eq a b) assume c: "c ∈ set (inl (snd X))" assume distinct: "a ≠ b" "b ≠ c" "a ≠ c" assume ab: "ccw 0 a b" and bc: "ccw 0 b c" show "ccw 0 a c" using a b c ab bc proof (cases "a = (0, 1)" "b = (0, 1)" "c = (0, 1)" rule: case_split[case_product case_split[case_product case_split]]) assume nu: "a ≠ (0, 1)" "b ≠ (0, 1)" "c ≠ (0, 1)" have "distinct5 a b c (0, 1) 0" "in5 UNIV a b c (0, 1) 0" using a b c distinct nu by (simp_all add: in_set_inl_nonzero) moreover have "ccw 0 (0, 1) a" "ccw 0 (0, 1) b" "ccw 0 (0, 1) c" by (auto intro!: nlex_ccw_left in_set_inl_lex a b c) ultimately show ?thesis using ab bc by (rule ccw.transitive[where S=UNIV and s="(0, 1)"]) next assume "a ≠ (0, 1)" "b = (0, 1)" "c ≠ (0, 1)" thus ?thesis using ccw_switch23 in_set_inl_lex inl_ncoll nlex_ccw_left a b ab by blast next assume "a ≠ (0, 1)" "b ≠ (0, 1)" "c = (0, 1)" thus ?thesis using ccw_switch23 in_set_inl_lex inl_ncoll nlex_ccw_left b c bc by blast qed (auto simp add: nlex_ccw_left in_set_inl_lex) qed lemma sorted_inl: "ccw.sortedP 0 (ccw.selsort 0 (inl (snd X)))" by (rule ccw0.sortedP_selsort) auto lemma sorted_scaled_inl: "ccw.sortedP 0 (map ((*⇩R) 2) (ccw.selsort 0 (inl (snd X))))" using sorted_inl by (rule ccw_sorted_scaleR) simp lemma distinct_selsort_inl: "distinct (ccw.selsort 0 (inl (snd X)))" by simp lemma distinct_map_scaleRI: fixes xs::"'a::real_vector list" shows "distinct xs ⟹ c ≠ 0 ⟹ distinct (map ((*⇩R) c) xs)" by (induct xs) auto lemma distinct_scaled_inl: "distinct (map ((*⇩R) 2) (ccw.selsort 0 (inl (snd X))))" using distinct_selsort_inl by (rule distinct_map_scaleRI) simp lemma ccw'_sortedP_scaled_inl: "ccw'.sortedP 0 (map ((*⇩R) 2) (ccw.selsort 0 (inl (snd X))))" using ccw_sorted_implies_ccw'_sortedP by (rule ccw'_sorted_scaleR) (auto simp: sorted_inl inl_ncoll) lemma pdevs_val_pdevs_of_list_inl2E: assumes "e ∈ UNIV → {-1 .. 1}" obtains e' where "pdevs_val e X = pdevs_val e' (pdevs_of_list (inl X))" "e' ∈ UNIV → {-1 .. 1}" proof - let ?l = "map snd (list_of_pdevs (nlex_pdevs X))" have l: "list_all (λx. Counterclockwise_2D_Arbitrary.lex x 0) ?l" "list_all (λx. x ≠ 0) (map snd (list_of_pdevs (nlex_pdevs X)))" by (auto simp: list_all_iff list_of_pdevs_def) from pdevs_val_nlex_pdevs[OF assms(1)] obtain e' where "e' ∈ UNIV → {-1 .. 1}" "pdevs_val e X = pdevs_val e' (nlex_pdevs X)" by auto note this(2) also from pdevs_val_of_list_of_pdevs2[OF ‹e' ∈ _›] obtain e'' where "e'' ∈ UNIV → {-1 .. 1}" "… = pdevs_val e'' (pdevs_of_list ?l)" by metis note this(2) also from pdevs_val_independent_pdevs[OF l ‹e'' ∈ _›] obtain e''' where "e''' ∈ UNIV → {-1 .. 1}" and "… = pdevs_val e''' (pdevs_of_list (independent_pdevs ?l))" by metis note this(2) also have "… = pdevs_val e''' (pdevs_of_list (inl X))" by (simp add: inl_def) finally have "pdevs_val e X = pdevs_val e''' (pdevs_of_list (inl X))" . thus thesis using ‹e''' ∈ _› .. qed lemma pdevs_val_pdevs_of_list_inlE: assumes "e ∈ UNIV → I" "uminus ` I = I" "0 ∈ I" obtains e' where "pdevs_val e (pdevs_of_list (inl X)) = pdevs_val e' X" "e' ∈ UNIV → I" proof - let ?l = "map snd (list_of_pdevs (nlex_pdevs X))" have "pdevs_val e (pdevs_of_list (inl X)) = pdevs_val e (pdevs_of_list (independent_pdevs ?l))" by (simp add: inl_def) also from pdevs_val_independent_pdevs2[OF ‹e ∈ _›] obtain e' where "pdevs_val e (pdevs_of_list (independent_pdevs ?l)) = pdevs_val e' (pdevs_of_list ?l)" and "e' ∈ UNIV → I" by auto note this(1) also from pdevs_val_of_list_of_pdevs[OF ‹e' ∈ _› ‹0 ∈ I›, of "nlex_pdevs X"] obtain e'' where "pdevs_val e' (pdevs_of_list ?l) = pdevs_val e'' (nlex_pdevs X)" and "e'' ∈ UNIV → I" by metis note this(1) also from pdevs_val_nlex_pdevs2[OF ‹e'' ∈ _› ‹_ = I›] obtain e''' where "pdevs_val e'' (nlex_pdevs X) = pdevs_val e''' X" "e''' ∈ UNIV → I" by metis note this(1) finally have "pdevs_val e (pdevs_of_list (inl X)) = pdevs_val e''' X" . thus ?thesis using ‹e''' ∈ UNIV → I› .. qed lemma sum_list_nlex_eq_sum_list_inl: "sum_list (map snd (list_of_pdevs (nlex_pdevs X))) = sum_list (inl X)" by (auto simp: inl_def sum_list_list_of_pdevs sum_list_independent_pdevs) lemma Affine_inl: "Affine (fst X, pdevs_of_list (inl (snd X))) = Affine X" by (auto simp: Affine_def valuate_def aform_val_def elim: pdevs_val_pdevs_of_list_inlE[of _ _ "snd X"] pdevs_val_pdevs_of_list_inl2E[of _ "snd X"]) subsection ‹Half Segments› definition half_segments_of_aform::"point aform ⇒ (point*point) list" where "half_segments_of_aform X = (let x0 = lowest_vertex (fst X, nlex_pdevs (snd X)) in polychain_of x0 (map ((*⇩R) 2) (ccw.selsort 0 (inl (snd X)))))" lemma subsequent_half_segments: fixes X assumes "Suc i < length (half_segments_of_aform X)" shows "snd (half_segments_of_aform X ! i) = fst (half_segments_of_aform X ! Suc i)" using assms by (cases i) (auto simp: half_segments_of_aform_def Let_def polychain_of_subsequent_eq) lemma polychain_half_segments_of_aform: "polychain (half_segments_of_aform X)" by (auto simp: subsequent_half_segments intro!: polychainI) lemma fst_half_segments: "half_segments_of_aform X ≠ [] ⟹ fst (half_segments_of_aform X ! 0) = lowest_vertex (fst X, nlex_pdevs (snd X))" by (auto simp: half_segments_of_aform_def Let_def o_def split_beta') lemma nlex_half_segments_of_aform: "(a, b) ∈ set (half_segments_of_aform X) ⟹ lex b a" by (auto simp: half_segments_of_aform_def prod_eq_iff lex_def dest!: in_set_polychain_ofD in_set_inl_lex) lemma ccw_half_segments_of_aform_all: assumes cd: "(c, d) ∈ set (half_segments_of_aform X)" shows "list_all (λ(xi, xj). ccw xi xj c ∧ ccw xi xj d) (half_segments_of_aform X)" proof - have "list_all (λ(xi, xj). ccw xi xj (fst (c, d)) ∧ ccw xi xj (snd (c, d))) (polychain_of (lowest_vertex (fst X, nlex_pdevs (snd X))) ((map ((*⇩R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X))))))" using ccw'_sortedP_scaled_inl cd[unfolded half_segments_of_aform_def Let_def] by (rule polychain_of_ccw_conjunction) thus ?thesis unfolding half_segments_of_aform_def[unfolded Let_def, symmetric] fst_conv snd_conv . qed lemma ccw_half_segments_of_aform: assumes ij: "(xi, xj) ∈ set (half_segments_of_aform X)" assumes c: "(c, d) ∈ set (half_segments_of_aform X)" shows "ccw xi xj c" "ccw xi xj d" using ccw_half_segments_of_aform_all[OF c] ij by (auto simp add: list_all_iff) lemma half_segments_of_aform1: assumes ch: "x ∈ convex hull set (map fst (half_segments_of_aform X))" assumes ab: "(a, b) ∈ set (half_segments_of_aform X)" shows "ccw a b x" using finite_set _ ch proof (rule ccw.convex_hull) fix c assume "c ∈ set (map fst (half_segments_of_aform X))" then obtain d where "(c, d) ∈ set (half_segments_of_aform X)" by auto with ab show "ccw a b c" by (rule ccw_half_segments_of_aform(1)) qed (insert ab, simp add: nlex_half_segments_of_aform) lemma half_segments_of_aform2: assumes ch: "x ∈ convex hull set (map snd (half_segments_of_aform X))" assumes ab: "(a, b) ∈ set (half_segments_of_aform X)" shows "ccw a b x" using finite_set _ ch proof (rule ccw.convex_hull) fix d assume "d ∈ set (map snd (half_segments_of_aform X))" then obtain c where "(c, d) ∈ set (half_segments_of_aform X)" by auto with ab show "ccw a b d" by (rule ccw_half_segments_of_aform(2)) qed (insert ab, simp add: nlex_half_segments_of_aform) lemma in_set_half_segments_of_aform_aform_valE: assumes "(x2, y2) ∈ set (half_segments_of_aform X)" obtains e where "y2 = aform_val e X" "e ∈ UNIV → {-1 .. 1}" proof - from assms obtain d where "y2 = lowest_vertex (fst X, nlex_pdevs (snd X)) + sum_list (take (Suc d) (map ((*⇩R) 2) (ccw.selsort 0 (inl (snd X)))))" by (auto simp: half_segments_of_aform_def elim!: in_set_polychain_of_imp_sum_list) also have "lowest_vertex (fst X, nlex_pdevs (snd X)) = fst X - sum_list (map snd (list_of_pdevs (nlex_pdevs (snd X))))" by (simp add: lowest_vertex_def) also have "sum_list (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = pdevs_val (λ_. 1) (nlex_pdevs (snd X))" by (auto simp: pdevs_val_sum_list) also have "sum_list (take (Suc d) (map ((*⇩R) 2) (ccw.selsort 0 (inl (snd X))))) = pdevs_val (λi. if i ≤ d then 2 else 0) (pdevs_of_list (ccw.selsort 0 (inl (snd X))))" (is "_ = pdevs_val ?e _") by (subst sum_list_take_pdevs_val_eq) (auto simp: pdevs_val_sum if_distrib pdevs_apply_pdevs_of_list degree_pdevs_of_list_scaleR intro!: sum.cong ) also obtain e'' where "… = pdevs_val e'' (pdevs_of_list (inl (snd X)))" "e'' ∈ UNIV → {0..2}" by (auto intro: pdevs_val_selsort_ccw2[of "inl (snd X)" ?e "{0 .. 2}"]) note this(1) also note inl_def also let ?l = "map snd (list_of_pdevs (nlex_pdevs (snd X)))" from pdevs_val_independent_pdevs2[OF ‹e'' ∈ _›] obtain e''' where "pdevs_val e'' (pdevs_of_list (independent_pdevs ?l)) = pdevs_val e''' (pdevs_of_list ?l)" and "e''' ∈ UNIV → {0..2}" by auto note this(1) also have "0 ∈ {0 .. 2::real}" by simp from pdevs_val_of_list_of_pdevs[OF ‹e''' ∈ _› this, of "nlex_pdevs (snd X)"] obtain e'''' where "pdevs_val e''' (pdevs_of_list ?l) = pdevs_val e'''' (nlex_pdevs (snd X))" and "e'''' ∈ UNIV → {0 .. 2}" by metis note this(1) finally have "y2 = fst X + (pdevs_val e'''' (nlex_pdevs (snd X)) - pdevs_val (λ_. 1) (nlex_pdevs (snd X)))" by simp also have "pdevs_val e'''' (nlex_pdevs (snd X)) - pdevs_val (λ_. 1) (nlex_pdevs (snd X)) = pdevs_val (λi. e'''' i - 1) (nlex_pdevs (snd X))" by (simp add: pdevs_val_minus) also have "(λi. e'''' i - 1) ∈ UNIV → {-1 .. 1}" using ‹e'''' ∈ _› by auto from pdevs_val_nlex_pdevs2[OF this] obtain f where "f ∈ UNIV → {-1 .. 1}" and "pdevs_val (λi. e'''' i - 1) (nlex_pdevs (snd X)) = pdevs_val f (snd X)" by auto note this(2) finally have "y2 = aform_val f X" by (simp add: aform_val_def) thus ?thesis using ‹f ∈ _› .. qed lemma fst_hd_half_segments_of_aform: assumes "half_segments_of_aform X ≠ []" shows "fst (hd (half_segments_of_aform X)) = lowest_vertex (fst X, (nlex_pdevs (snd X)))" using assms by (auto simp: half_segments_of_aform_def Let_def fst_hd_polychain_of) lemma "linorder_list0.sortedP (ccw' (lowest_vertex (fst X, nlex_pdevs (snd X)))) (map snd (half_segments_of_aform X))" (is "linorder_list0.sortedP (ccw' ?x0) ?ms") unfolding half_segments_of_aform_def Let_def by (rule ccw'_sortedP_polychain_of_snd) (rule ccw'_sortedP_scaled_inl) lemma rev_zip: "length xs = length ys ⟹ rev (zip xs ys) = zip (rev xs) (rev ys)" by (induct xs ys rule: list_induct2) auto lemma zip_upt_self_aux: "zip [0..<length xs] xs = map (λi. (i, xs ! i)) [0..<length xs]" by (auto intro!: nth_equalityI) lemma half_segments_of_aform_strict: assumes "e ∈ UNIV → {-1 <..< 1}" assumes "seg ∈ set (half_segments_of_aform X)" assumes "length (half_segments_of_aform X) ≠ 1" shows "ccw' (fst seg) (snd seg) (aform_val e X)" using assms unfolding half_segments_of_aform_def Let_def proof - have len: "length (map ((*⇩R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X)))) ≠ 1" using assms by (auto simp: half_segments_of_aform_def) have "aform_val e X = fst X + pdevs_val e (snd X)" by (simp add: aform_val_def) also obtain e' where "e' ∈ UNIV → {-1 <..< 1}" "pdevs_val e (snd X) = pdevs_val e' (nlex_pdevs (snd X))" using pdevs_val_nlex_pdevs[OF ‹e ∈ _›] by auto note this(2) also obtain e'' where "e'' ∈ UNIV → {-1 <..< 1}" "… = pdevs_val e'' (pdevs_of_list (map snd (list_of_pdevs (nlex_pdevs (snd X)))))" by (metis pdevs_val_of_list_of_pdevs2[OF ‹e' ∈ _›]) note this(2) also obtain e''' where "e''' ∈ UNIV → {-1 <..< 1}" "… = pdevs_val e''' (pdevs_of_list (inl (snd X)))" unfolding inl_def using pdevs_val_independent_pdevs_strict[OF list_all_list_of_pdevsI, OF lex_nlex_pdevs list_of_pdevs_all_nonzero ‹e'' ∈ _›] by metis note this(2) also from pdevs_val_selsort_ccw[OF distinct_inl ‹e''' ∈ _›] obtain f where "f ∈ UNIV → {-1 <..< 1}" "… = pdevs_val f (pdevs_of_list (linorder_list0.selsort (ccw 0) (inl (snd X))))" (is "_ = pdevs_val _ (pdevs_of_list ?sl)") by metis note this(2) also have "… = pdevs_val (λi. f i + 1) (pdevs_of_list ?sl) + lowest_vertex (fst X, nlex_pdevs (snd X)) - fst X" proof - have "sum_list (dense_list_of_pdevs (nlex_pdevs (snd X))) = sum_list (dense_list_of_pdevs (pdevs_of_list (ccw.selsort 0 (inl (snd X)))))" by (subst dense_list_of_pdevs_pdevs_of_list) (auto simp: in_set_independent_pdevs_nonzero dense_list_of_pdevs_pdevs_of_list inl_def sum_list_distinct_selsort sum_list_independent_pdevs sum_list_list_of_pdevs) thus ?thesis by (auto simp add: pdevs_val_add lowest_vertex_def algebra_simps pdevs_val_sum_list sum_list_list_of_pdevs in_set_inl_nonzero dense_list_of_pdevs_pdevs_of_list) qed also have "pdevs_val (λi. f i + 1) (pdevs_of_list ?sl) = pdevs_val (λi. 1/2 * (f i + 1)) (pdevs_of_list (map ((*⇩R) 2) ?sl))" (is "_ = pdevs_val ?f' (pdevs_of_list ?ssl)") by (subst pdevs_val_cmul) (simp add: pdevs_of_list_map_scaleR) also have "distinct ?ssl" "?f' ∈ UNIV → {0<..<1}" using ‹f ∈ _› by (auto simp: distinct_map_scaleRI Pi_iff algebra_simps real_0_less_add_iff) from pdevs_of_list_sum[OF this] obtain g where "g ∈ UNIV → {0<..<1}" "pdevs_val ?f' (pdevs_of_list ?ssl) = (∑P∈set ?ssl. g P *⇩R P)" by blast note this(2) finally have "aform_val e X = lowest_vertex (fst X, nlex_pdevs (snd X)) + (∑P∈set ?ssl. g P *⇩R P)" by simp also have "ccw' (fst seg) (snd seg) …" using ‹g ∈ _› _ len ‹seg ∈ _›[unfolded half_segments_of_aform_def Let_def] by (rule in_polychain_of_ccw) (simp add: ccw'_sortedP_scaled_inl) finally show ?thesis . qed lemma half_segments_of_aform_strict_all: assumes "e ∈ UNIV → {-1 <..< 1}" assumes "length (half_segments_of_aform X) ≠ 1" shows "list_all (λseg. ccw' (fst seg) (snd seg) (aform_val e X)) (half_segments_of_aform X)" using assms by (auto intro!: half_segments_of_aform_strict simp: list_all_iff) lemma list_allD: "list_all P xs ⟹ x ∈ set xs ⟹ P x" by (auto simp: list_all_iff) lemma minus_one_less_multI: fixes e x::real shows "- 1 ≤ e ⟹ 0 < x ⟹ x < 1 ⟹ - 1 < e * x" by (metis abs_add_one_gt_zero abs_real_def le_less_trans less_not_sym mult_less_0_iff mult_less_cancel_left1 real_0_less_add_iff) lemma less_one_multI: fixes e x::real shows "e ≤ 1 ⟹ 0 < x ⟹ x < 1 ⟹ e * x < 1" by (metis (erased, hide_lams) less_eq_real_def monoid_mult_class.mult.left_neutral mult_strict_mono zero_less_one) lemma ccw_half_segments_of_aform_strictI: assumes "e ∈ UNIV → {-1 <..< 1}" assumes "(s1, s2) ∈ set (half_segments_of_aform X)" assumes "length (half_segments_of_aform X) ≠ 1" assumes "x = (aform_val e X)" shows "ccw' s1 s2 x" using half_segments_of_aform_strict[OF assms(1-3)] assms(4) by simp lemma ccw'_sortedP_subsequent: assumes "Suc i < length xs" "ccw'.sortedP 0 (map dirvec xs)" "fst (xs ! Suc i) = snd (xs ! i)" shows "ccw' (fst (xs ! i)) (snd (xs ! i)) (snd (xs ! Suc i))" using assms proof (induct xs arbitrary: i) case Nil thus ?case by simp next case (Cons x xs) thus ?case by (auto simp: nth_Cons dirvec_minus split: nat.split elim!: ccw'.sortedP_Cons) (metis (no_types, lifting) ccw'.renormalize length_greater_0_conv nth_mem prod.case_eq_if) qed lemma ccw'_sortedP_uminus: "ccw'.sortedP 0 xs ⟹ ccw'.sortedP 0 (map uminus xs)" by (induct xs) (auto intro!: ccw'.sortedP.Cons elim!: ccw'.sortedP_Cons simp del: uminus_Pair) lemma subsequent_half_segments_ccw: fixes X assumes "Suc i < length (half_segments_of_aform X)" shows "ccw' (fst (half_segments_of_aform X ! i)) (snd (half_segments_of_aform X ! i)) (snd (half_segments_of_aform X ! Suc i))" using assms by (intro ccw'_sortedP_subsequent ) (auto simp: subsequent_half_segments half_segments_of_aform_def sorted_inl polychain_of_subsequent_eq intro!: ccw_sorted_implies_ccw'_sortedP[OF inl_ncoll] ccw'_sorted_scaleR) lemma convex_polychain_half_segments_of_aform: "convex_polychain (half_segments_of_aform X)" proof cases assume "length (half_segments_of_aform X) = 1" thus ?thesis by (auto simp: length_Suc_conv convex_polychain_def polychain_def) next assume len: "length (half_segments_of_aform X) ≠ 1" show ?thesis by (rule convex_polychainI) (simp_all add: polychain_half_segments_of_aform subsequent_half_segments_ccw ccw'_def[symmetric]) qed lemma hd_distinct_neq_last: "distinct xs ⟹ length xs > 1 ⟹ hd xs ≠ last xs" by (metis One_nat_def add_Suc_right distinct.simps(2) last.simps last_in_set less_irrefl list.exhaust list.sel(1) list.size(3) list.size(4) add.right_neutral nat_neq_iff not_less0) lemma ccw_hd_last_half_segments_dirvec: assumes "length (half_segments_of_aform X) > 1" shows "ccw' 0 (dirvec (hd (half_segments_of_aform X))) (dirvec (last (half_segments_of_aform X)))" proof - let ?i = "ccw.selsort 0 (inl (snd X))" let ?s = "map ((*⇩R) 2) (ccw.selsort 0 (inl (snd X)))" from assms have l: "1 < length (inl (snd X))" "inl (snd X) ≠ []" using assms by (auto simp add: half_segments_of_aform_def) hence "hd ?i ∈ set ?i" "last ?i ∈ set ?i" by (auto intro!: hd_in_set last_in_set simp del: ccw.set_selsort) hence "¬coll 0 (hd ?i) (last ?i)" using l by (intro inl_ncoll[of _ X]) (auto simp: hd_distinct_neq_last) hence "¬coll 0 (hd ?s) (last ?s)" using l by (auto simp: hd_map last_map) hence "ccw' 0 (hd (map ((*⇩R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X))))) (last (map ((*⇩R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X)))))" using assms by (auto simp add: half_segments_of_aform_def intro!: sorted_inl ccw_sorted_scaleR ccw.hd_last_sorted ccw_ncoll_imp_ccw) with assms show ?thesis by (auto simp add: half_segments_of_aform_def Let_def dirvec_hd_polychain_of dirvec_last_polychain_of length_greater_0_conv[symmetric] simp del: polychain_of.simps length_greater_0_conv split: if_split_asm) qed lemma map_fst_half_segments_aux_eq: "[] ≠ half_segments_of_aform X ⟹ map fst (half_segments_of_aform X) = fst (hd (half_segments_of_aform X))#butlast (map snd (half_segments_of_aform X))" by (rule nth_equalityI) (auto simp: nth_Cons hd_conv_nth nth_butlast subsequent_half_segments split: nat.split) lemma le_less_Suc_eq: "x - Suc 0 ≤ (i::nat) ⟹ i < x ⟹ x - Suc 0 = i" by simp lemma map_snd_half_segments_aux_eq: "half_segments_of_aform X ≠ [] ⟹ map snd (half_segments_of_aform X) = tl (map fst (half_segments_of_aform X)) @ [snd (last (half_segments_of_aform X))]" by (rule nth_equalityI) (auto simp: nth_Cons hd_conv_nth nth_append nth_tl subsequent_half_segments not_less last_conv_nth algebra_simps dest!: le_less_Suc_eq split: nat.split) lemma ccw'_sortedP_snd_half_segments_of_aform: "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X))) (map snd (half_segments_of_aform X))" by (auto simp: half_segments_of_aform_def Let_def intro!: ccw'.sortedP.Cons ccw'_sortedP_polychain_of_snd ccw'_sortedP_scaled_inl) lemma lex_half_segments_lowest_vertex: assumes "(c, d) ∈ set (half_segments_of_aform X)" shows "lex d (lowest_vertex (fst X, nlex_pdevs (snd X)))" unfolding half_segments_of_aform_def Let_def by (rule lex_polychain_of_center[OF assms[unfolded half_segments_of_aform_def Let_def], unfolded snd_conv]) (auto simp: list_all_iff lex_def dest!: in_set_inl_lex) lemma lex_half_segments_lowest_vertex': assumes "d ∈ set (map snd (half_segments_of_aform X))" shows "lex d (lowest_vertex (fst X, nlex_pdevs (snd X)))" using assms by (auto intro: lex_half_segments_lowest_vertex) lemma lex_half_segments_last: assumes "(c, d) ∈ set (half_segments_of_aform X)" shows "lex (snd (last (half_segments_of_aform X))) d" using assms unfolding half_segments_of_aform_def Let_def by (rule lex_polychain_of_last) (auto simp: list_all_iff lex_def dest!: in_set_inl_lex) lemma lex_half_segments_last': assumes "d ∈ set (map snd (half_segments_of_aform X))" shows "lex (snd (last (half_segments_of_aform X))) d" using assms by (auto intro: lex_half_segments_last) lemma ccw'_half_segments_lowest_last: assumes set_butlast: "(c, d) ∈ set (butlast (half_segments_of_aform X))" assumes ne: "inl (snd X) ≠ []" shows "ccw' (lowest_vertex (fst X, nlex_pdevs (snd X))) d (snd (last (half_segments_of_aform X)))" using set_butlast unfolding half_segments_of_aform_def Let_def by (rule ccw'_polychain_of_sorted_center_last) (auto simp: ne ccw'_sortedP_scaled_inl) lemma distinct_fst_half_segments: "distinct (map fst (half_segments_of_aform X))" by (auto simp: half_segments_of_aform_def list_all_iff lex_scale1_zero simp del: scaleR_Pair intro!: distinct_fst_polychain_of dest: in_set_inl_nonzero in_set_inl_lex) lemma distinct_snd_half_segments: "distinct (map snd (half_segments_of_aform X))" by (auto simp: half_segments_of_aform_def list_all_iff lex_scale1_zero simp del: scaleR_Pair intro!: distinct_snd_polychain_of dest: in_set_inl_nonzero in_set_inl_lex) subsection ‹Mirror› definition "mirror_point x y = 2 *⇩R x - y" lemma ccw'_mirror_point3[simp]: "ccw' (mirror_point x y) (mirror_point x z) (mirror_point x w) ⟷ ccw' y z w " by (auto simp: mirror_point_def det3_def' ccw'_def algebra_simps) lemma mirror_point_self_inverse[simp]: fixes x::"'a::real_vector" shows "mirror_point p (mirror_point p x) = x" by (auto simp: mirror_point_def scaleR_2) lemma mirror_half_segments_of_aform: assumes "e ∈ UNIV → {-1 <..< 1}" assumes "length (half_segments_of_aform X) ≠ 1" shows "list_all (λseg. ccw' (fst seg) (snd seg) (aform_val e X)) (map (pairself (mirror_point (fst X))) (half_segments_of_aform X))" unfolding list_all_length proof safe let ?m = "map (pairself (mirror_point (fst X))) (half_segments_of_aform X)" fix n assume "n < length ?m" hence "ccw' (fst (half_segments_of_aform X ! n)) (snd (half_segments_of_aform X ! n)) (aform_val (- e) X)" using assms by (auto dest!: nth_mem intro!: half_segments_of_aform_strict) also have "aform_val (-e) X = 2 *⇩R fst X - aform_val e X" by (auto simp: aform_val_def pdevs_val_sum algebra_simps scaleR_2 sum_negf) finally have le: "ccw' (fst (half_segments_of_aform X ! n)) (snd (half_segments_of_aform X ! n)) (2 *⇩R fst X - aform_val e X)" . have eq: "(map (pairself (mirror_point (fst X))) (half_segments_of_aform X) ! n) = (2 *⇩R fst X - fst ((half_segments_of_aform X) ! n), 2 *⇩R fst X - snd ((half_segments_of_aform X) ! n))" using ‹n < length ?m› by (cases "half_segments_of_aform X ! n") (auto simp add: mirror_point_def) show "ccw' (fst (?m ! n)) (snd (?m ! n)) (aform_val e X)" using le unfolding eq by (auto simp: algebra_simps ccw'_def det3_def') qed lemma last_half_segments: assumes "half_segments_of_aform X ≠ []" shows "snd (last (half_segments_of_aform X)) = mirror_point (fst X) (lowest_vertex (fst X, nlex_pdevs (snd X)))" using assms by (auto simp add: half_segments_of_aform_def Let_def lowest_vertex_def mirror_point_def scaleR_2 scaleR_sum_list[symmetric] last_polychain_of sum_list_distinct_selsort inl_def sum_list_independent_pdevs sum_list_list_of_pdevs) lemma convex_polychain_map_mirror: assumes "convex_polychain hs" shows "convex_polychain (map (pairself (mirror_point x)) hs)" proof (rule convex_polychainI) qed (insert assms, auto simp: convex_polychain_def polychain_map_pairself pairself_apply mirror_point_def det3_def' algebra_simps) lemma ccw'_mirror_point0: "ccw' (mirror_point x y) z w ⟷ ccw' y (mirror_point x z) (mirror_point x w)" by (metis ccw'_mirror_point3 mirror_point_self_inverse) lemma ccw'_sortedP_mirror: "ccw'.sortedP x0 (map (mirror_point p0) xs) ⟷ ccw'.sortedP (mirror_point p0 x0) xs" by (induct xs) (simp_all add: linorder_list0.sortedP.Nil linorder_list0.sortedP_Cons_iff ccw'_mirror_point0) lemma ccw'_sortedP_mirror2: "ccw'.sortedP (mirror_point p0 x0) (map (mirror_point p0) xs) ⟷ ccw'.sortedP x0 xs" using ccw'_sortedP_mirror[of "mirror_point p0 x0" p0 xs] by simp lemma map_mirror_o_snd_polychain_of_eq: "map (mirror_point x0 ∘ snd) (polychain_of y xs) = map snd (polychain_of (mirror_point x0 y) (map uminus xs))" by (induct xs arbitrary: x0 y) (auto simp: mirror_point_def o_def algebra_simps) lemma lowest_vertex_eq_mirror_last: "half_segments_of_aform X ≠ [] ⟹ (lowest_vertex (fst X, nlex_pdevs (snd X))) = mirror_point (fst X) (snd (last (half_segments_of_aform X)))" using last_half_segments[of X] by simp lemma snd_last: "xs ≠ [] ⟹ snd (last xs) = last (map snd xs)" by (induct xs) auto lemma mirror_point_snd_last_eq_lowest: "half_segments_of_aform X ≠ [] ⟹ mirror_point (fst X) (last (map snd (half_segments_of_aform X))) = lowest_vertex (fst X, nlex_pdevs (snd X))" by (simp add: lowest_vertex_eq_mirror_last snd_last) lemma lex_mirror_point: "lex (mirror_point x0 a) (mirror_point x0 b) ⟹ lex b a" by (auto simp: mirror_point_def lex_def) lemma ccw'_mirror_point: "ccw' (mirror_point x0 a) (mirror_point x0 b) (mirror_point x0 c) ⟹ ccw' a b c" by (auto simp: mirror_point_def) lemma inj_mirror_point: "inj (mirror_point (x::'a::real_vector))" by (auto simp: mirror_point_def inj_on_def algebra_simps) lemma distinct_map_mirror_point_eq: "distinct (map (mirror_point (x::'a::real_vector)) xs) = distinct xs" by (auto simp: distinct_map intro!: subset_inj_on[OF inj_mirror_point]) lemma eq_self_mirror_iff: fixes x::"'a::real_vector" shows "x = mirror_point y x ⟷ x = y" by (auto simp: mirror_point_def algebra_simps scaleR_2[symmetric]) subsection ‹Full Segments› definition segments_of_aform::"point aform ⇒ (point * point) list" where "segments_of_aform X = (let hs = half_segments_of_aform X in hs @ map (pairself (mirror_point (fst X))) hs)" lemma segments_of_aform_strict: assumes "e ∈ UNIV → {-1 <..< 1}" assumes "length (half_segments_of_aform X) ≠ 1" shows "list_all (λseg. ccw' (fst seg) (snd seg) (aform_val e X)) (segments_of_aform X)" using assms by (auto simp: segments_of_aform_def Let_def mirror_half_segments_of_aform half_segments_of_aform_strict_all) lemma mirror_point_aform_val[simp]: "mirror_point (fst X) (aform_val e X) = aform_val (- e) X" by (auto simp: mirror_point_def aform_val_def pdevs_val_sum algebra_simps scaleR_2 sum_negf) lemma in_set_segments_of_aform_aform_valE: assumes "(x2, y2) ∈ set (segments_of_aform X)" obtains e where "y2 = aform_val e X" "e ∈ UNIV → {-1 .. 1}" using assms proof (auto simp: segments_of_aform_def Let_def) assume "(x2, y2) ∈ set (half_segments_of_aform X)" from in_set_half_segments_of_aform_aform_valE[OF this] obtain e where "y2 = aform_val e X" "e ∈ UNIV → {- 1..1}" by auto thus ?thesis .. next fix a b aa ba assume "((a, b), aa, ba) ∈ set (half_segments_of_aform X)" from in_set_half_segments_of_aform_aform_valE[OF this] obtain e where e: "(aa, ba) = aform_val e X" "e ∈ UNIV → {- 1..1}" by auto assume "y2 = mirror_point (fst X) (aa, ba)" hence "y2 = aform_val (-e) X" "(-e) ∈ UNIV → {-1 .. 1}" using e by auto thus ?thesis .. qed lemma last_half_segments_eq_mirror_hd: assumes "half_segments_of_aform X ≠ []" shows "snd (last (half_segments_of_aform X)) = mirror_point (fst X) (fst (hd (half_segments_of_aform X)))" by (simp add: last_half_segments assms fst_hd_half_segments_of_aform) lemma polychain_segments_of_aform: "polychain (segments_of_aform X)" by (auto simp: segments_of_aform_def Let_def polychain_half_segments_of_aform polychain_map_pairself last_half_segments_eq_mirror_hd hd_map pairself_apply intro!: polychain_appendI) lemma segments_of_aform_closed: assumes "segments_of_aform X ≠ []" shows "fst (hd (segments_of_aform X)) = snd (last (segments_of_aform X))" using assms by (auto simp: segments_of_aform_def Let_def fst_hd_half_segments_of_aform last_map pairself_apply last_half_segments mirror_point_def) lemma convex_polychain_segments_of_aform: assumes "1 < length (half_segments_of_aform X)" shows "convex_polychain (segments_of_aform X)" unfolding segments_of_aform_def Let_def using ccw_hd_last_half_segments_dirvec[OF assms] by (intro convex_polychain_appendI) (auto simp: convex_polychain_half_segments_of_aform convex_polychain_map_mirror dirvec_minus hd_map pairself_apply last_half_segments mirror_point_def fst_hd_half_segments_of_aform det3_def' algebra_simps ccw'_def intro!: polychain_appendI polychain_half_segments_of_aform polychain_map_pairself) lemma convex_polygon_segments_of_aform: assumes "1 < length (half_segments_of_aform X)" shows "convex_polygon (segments_of_aform X)" proof - from assms have hne: "half_segments_of_aform X ≠ []" by auto from convex_polychain_segments_of_aform[OF assms] have "convex_polychain (segments_of_aform X)" . thus ?thesis by (auto simp: convex_polygon_def segments_of_aform_closed) qed lemma previous_segments_of_aformE: assumes "(y, z) ∈ set (segments_of_aform X)" obtains x where "(x, y) ∈ set (segments_of_aform X)" proof - from assms have ne[simp]: "segments_of_aform X ≠ []" by auto from assms obtain i where i: "i<length (segments_of_aform X)" "(segments_of_aform X) ! i = (y, z)" by (auto simp: in_set_conv_nth) show ?thesis proof (cases i) case 0 with segments_of_aform_closed[of X] assms have "(fst (last (segments_of_aform X)), y) ∈ set (segments_of_aform X)" by (metis fst_conv hd_conv_nth i(2) last_in_set ne snd_conv surj_pair) thus ?thesis .. next case (Suc j) have "(fst (segments_of_aform X ! j), snd (segments_of_aform X ! j)) ∈ set (segments_of_aform X)" using Suc i(1) by auto also from i have "y = fst (segments_of_aform X ! i)" by auto hence "snd (segments_of_aform X ! j) = y" using polychain_segments_of_aform[of X] i(1) Suc by (auto simp: polychain_def Suc) finally have "(fst (segments_of_aform X ! j), y) ∈ set (segments_of_aform X)" . thus ?thesis .. qed qed lemma fst_compose_pairself: "fst o pairself f = f o fst" and snd_compose_pairself: "snd o pairself f = f o snd" by (auto simp: pairself_apply) lemma in_set_butlastI: "xs ≠ [] ⟹ x ∈ set xs ⟹ x ≠ last xs ⟹ x ∈ set (butlast xs)" by (induct xs) (auto split: if_splits) lemma distinct_in_set_butlastD: "x ∈ set (butlast xs) ⟹ distinct xs ⟹ x ≠ last xs" by (induct xs) auto lemma distinct_in_set_tlD: "x ∈ set (tl xs) ⟹ distinct xs ⟹ x ≠ hd xs" by (induct xs) auto lemma ccw'_sortedP_snd_segments_of_aform: assumes "length (inl (snd X)) > 1" shows "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X))) (butlast (map snd (segments_of_aform X)))" proof cases assume "[] = half_segments_of_aform X" from this show ?thesis by (simp add: segments_of_aform_def Let_def ccw'.sortedP.Nil) next assume H: "[] ≠ half_segments_of_aform X" let ?m = "mirror_point (fst X)" have ne: "inl (snd X) ≠ []" using assms by auto have "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X))) (map snd (half_segments_of_aform X) @ butlast (map (?m ∘ snd) (half_segments_of_aform X)))" proof (rule ccw'.sortedP_appendI) show "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X))) (map snd (half_segments_of_aform X))" by (rule ccw'_sortedP_snd_half_segments_of_aform) have "butlast (map (?m ∘ snd) (half_segments_of_aform X)) = butlast (map (?m ∘ snd) (polychain_of (lowest_vertex (fst X, nlex_pdevs (snd X))) (map ((*⇩R) 2) (ccw.selsort 0 (inl (snd X))))))" by (simp add: half_segments_of_aform_def) also have "… = map snd (butlast (polychain_of (?m (lowest_vertex (fst X, nlex_pdevs (snd X)))) (map uminus (map ((*⇩R) 2) (ccw.selsort 0 (inl (snd X)))))))" (is "_ = map snd (butlast (polychain_of ?x ?xs))") by (simp add: map_mirror_o_snd_polychain_of_eq map_butlast) also { have "ccw'.sortedP 0 ?xs" by (intro ccw'_sortedP_uminus ccw'_sortedP_scaled_inl) moreover have "ccw'.sortedP ?x (map snd (polychain_of ?x ?xs))" unfolding ccw'_sortedP_mirror[symmetric] map_map map_mirror_o_snd_polychain_of_eq by (auto simp add: o_def intro!: ccw'_sortedP_polychain_of_snd ccw'_sortedP_scaled_inl) ultimately have "ccw'.sortedP (snd (last (polychain_of ?x ?xs))) (map snd (butlast (polychain_of ?x ?xs)))" by (rule ccw'_sortedP_convex_rotate_aux) } also have "(snd (last (polychain_of ?x ?xs))) = ?m (last (map snd (half_segments_of_aform X)))" by (simp add: half_segments_of_aform_def ne map_mirror_o_snd_polychain_of_eq last_map[symmetric, where f="?m"] last_map[symmetric, where f="snd"]) also have "… = lowest_vertex (fst X, nlex_pdevs (snd X))" using ne H by (auto simp: lowest_vertex_eq_mirror_last snd_last) finally show "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X))) (butlast (map (?m ∘ snd) (half_segments_of_aform X)))" . next fix x y assume seg: "x ∈ set (map snd (half_segments_of_aform X))" and mseg: "y ∈ set (butlast (map (?m ∘ snd) (half_segments_of_aform X)))" from seg assms have neq_Nil: "inl (snd X) ≠ []" "half_segments_of_aform X ≠ []" by auto from seg obtain a where a: "(a, x) ∈ set (half_segments_of_aform X)" by auto from mseg obtain b where mirror_y: "(b, ?m y) ∈ set (butlast (half_segments_of_aform X))" by (auto simp: map_butlast[symmetric]) let ?l = "lowest_vertex (fst X, nlex_pdevs (snd X))" let ?ml = "?m ?l" have mirror_eq_last: "?ml = snd (last (half_segments_of_aform X))" using seg H by (intro last_half_segments[symmetric]) simp define r where "r = ?l + (0, abs (snd x - snd ?l) + abs (snd y - snd ?l) + abs (snd ?ml - snd ?l) + 1)" have d1: "x ≠ r" "y ≠ r" "?l ≠ r" "?ml ≠ r" by (auto simp: r_def plus_prod_def prod_eq_iff) have "distinct (map (?m ∘ snd) (half_segments_of_aform X))" unfolding map_comp_map[symmetric] unfolding o_def distinct_map_mirror_point_eq by (rule distinct_snd_half_segments) from distinct_in_set_butlastD[OF ‹y ∈ _› this] have "?l ≠ y" by (simp add: neq_Nil lowest_vertex_eq_mirror_last last_map) moreover have "?l ≠ ?ml" using neq_Nil by (auto simp add: eq_self_mirror_iff lowest_vertex_eq_center_iff inl_def) ultimately have d2: "?l ≠ y" "?l ≠ ?ml" by auto have *: "ccw' ?l (?m y) ?ml" by (metis mirror_eq_last ccw'_half_segments_lowest_last mirror_y neq_Nil(1)) have "ccw' ?ml y ?l" by (rule ccw'_mirror_point[of "fst X"]) (simp add: *) hence lmy: "ccw' ?l ?ml y" by (simp add: ccw'_def det3_def' algebra_simps) let ?ccw = "ccw' (lowest_vertex (fst X, nlex_pdevs (snd X))) x y" { assume "x ≠ ?ml" hence x_butlast: "(a, x) ∈ set (butlast (half_segments_of_aform X))" unfolding mirror_eq_last using a by (auto intro!: in_set_butlastI simp: prod_eq_iff) have "ccw' ?l x ?ml" by (metis mirror_eq_last ccw'_half_segments_lowest_last x_butlast neq_Nil(1)) } note lxml = this { assume "x = ?ml" hence ?ccw by (simp add: lmy) } moreover { assume "x ≠ ?ml" "y = ?ml" hence ?ccw by (simp add: lxml) } moreover { assume d3: "x ≠ ?ml" "y ≠ ?ml" from ‹x ∈ set _› have "x ∈ set (map snd (half_segments_of_aform X))" by force hence "x ∈ set (tl (map fst (half_segments_of_aform X)))" using d3 unfolding map_snd_half_segments_aux_eq[OF neq_Nil(2)] by (auto simp: mirror_eq_last) from distinct_in_set_tlD[OF this distinct_fst_half_segments] have "?l ≠ x" by (simp add: fst_hd_half_segments_of_aform neq_Nil hd_map) from lxml[OF ‹x ≠ ?ml›] ‹ccw' ?l ?ml y› have d4: "x ≠ y" by (rule neq_left_right_of lxml) have "distinct5 x ?ml y r ?l" using d1 d2 ‹?l ≠ x› d3 d4 by simp_all moreover note _ moreover have "lex x ?l" by (rule lex_half_segments_lowest_vertex) fact hence "ccw ?l r x" unfolding r_def by (rule lex_ccw_left) simp moreover have "lex ?ml ?l" using last_in_set[OF H[symmetric]] by (auto simp: mirror_eq_last intro: lex_half_segments_lowest_vertex') hence "ccw ?l r ?ml" unfolding r_def by (rule lex_ccw_left) simp moreover have "lex (?m (lowest_vertex (fst X, nlex_pdevs (snd X)))) (?m y)" using mirror_y by (force dest!: in_set_butlastD intro: lex_half_segments_last' simp: mirror_eq_last ) hence "lex y ?l" by (rule lex_mirror_point) hence "ccw ?l r y" unfolding r_def by (rule lex_ccw_left) simp moreover from ‹x ≠ ?ml› have "ccw ?l x ?ml" by (simp add: ccw_def lxml) moreover from lmy have "ccw ?l ?ml y" by (simp add: ccw_def) ultimately have "ccw ?l x y" by (rule ccw.transitive[where S=UNIV]) simp moreover { have "x ≠ ?l" using ‹?l ≠ x› by simp moreover have "lex (?m y) (?m ?ml)" using mirror_y by (force intro: lex_half_segments_lowest_vertex in_set_butlastD) hence "lex ?ml y" by (rule lex_mirror_point) moreover from a have "lex ?ml x" unfolding mirror_eq_last by (rule lex_half_segments_last) moreover note ‹lex y ?l› ‹lex x ?l› ‹ccw' ?l x ?ml› ‹ccw' ?l ?ml y› ultimately have ncoll: "¬ coll ?l x y" by (rule not_coll_ordered_lexI) } ultimately have ?ccw by (simp add: ccw_def) } ultimately show ?ccw by blast qed thus ?thesis using H by (simp add: segments_of_aform_def Let_def butlast_append snd_compose_pairself) qed lemma polychain_of_segments_of_aform1: assumes "length (segments_of_aform X) = 1" shows "False" using assms by (auto simp: segments_of_aform_def Let_def half_segments_of_aform_def add_is_1 split: if_split_asm) lemma polychain_of_segments_of_aform2: assumes "segments_of_aform X = [x, y]" assumes "between (fst x, snd x) p" shows "p ∈ convex hull set (map fst (segments_of_aform X))" proof - from polychain_segments_of_aform[of X] segments_of_aform_closed[of X] assms have "fst y = snd x" "snd y = fst x" by (simp_all add: polychain_def) thus ?thesis using assms by (cases x) (auto simp: between_mem_convex_hull) qed lemma append_eq_2: assumes "length xs = length ys" shows "xs @ ys = [x, y] ⟷ xs = [x] ∧ ys = [y]" using assms proof (cases xs) case (Cons z zs) thus ?thesis using assms by (cases zs) auto qed simp lemma segments_of_aform_line_segment: assumes "segments_of_aform X = [x, y]" assumes "e ∈ UNIV → {-1 .. 1}" shows "aform_val e X ∈ closed_segment (fst x) (snd x)" proof - from pdevs_val_pdevs_of_list_inl2E[OF ‹e ∈ _›, of "snd X"] obtain e' where e': "pdevs_val e (snd X) = pdevs_val e' (pdevs_of_list (inl (snd X)))" "e' ∈ UNIV → {- 1..1}" . from e' have "0 ≤ 1 + e' 0" by (auto simp: Pi_iff dest!: spec[where x=0]) with assms e' show ?thesis by (auto simp: segments_of_aform_def Let_def append_eq_2 half_segments_of_aform_def polychain_of_singleton_iff mirror_point_def ccw.selsort_singleton_iff lowest_vertex_def aform_val_def sum_list_nlex_eq_sum_list_inl closed_segment_def Pi_iff intro!: exI[where x="(1 + e' 0) / 2"]) (auto simp: algebra_simps) qed subsection ‹Continuous Generalization› lemma LIMSEQ_minus_fract_mult: "(λn. r * (1 - 1 / real (Suc (Suc n)))) ⇢ r" by (rule tendsto_eq_rhs[OF tendsto_mult[where a=r and b = 1]]) (auto simp: inverse_eq_divide[symmetric] simp del: of_nat_Suc intro: filterlim_compose[OF LIMSEQ_inverse_real_of_nat filterlim_Suc] tendsto_eq_intros) lemma det3_nonneg_segments_of_aform: assumes "e ∈ UNIV → {-1 .. 1}" assumes "length (half_segments_of_aform X) ≠ 1" shows "list_all (λseg. det3 (fst seg) (snd seg) (aform_val e X) ≥ 0) (segments_of_aform X)" unfolding list_all_iff proof safe fix a b c d assume seg: "((a, b), c, d) ∈ set (segments_of_aform X)" (is "?seg ∈ _") define normal_of_segment where "normal_of_segment = (λ((a0, a1), b0, b1). (b1 - a1, a0 - b0)::real*real)" define support_of_segment where "support_of_segment = (λ(a, b). normal_of_segment (a, b) ∙ a)" have "closed ((λx. x ∙ normal_of_segment ?seg) -` {..support_of_segment ?seg})" (is "closed ?cl") by (auto intro!: continuous_intros closed_vimage) moreover define f where "f n i = e i * ( 1 - 1 / (Suc (Suc n)))" for n i have "∀n. aform_val (f n) X ∈ ?cl" proof fix n have "f n ∈ UNIV → {-1 <..< 1}" using assms by (auto simp: f_def Pi_iff intro!: less_one_multI minus_one_less_multI) from list_allD[OF segments_of_aform_strict[OF this assms(2)] seg] show "aform_val (f n) X ∈ (λx. x ∙ normal_of_segment ((a, b), c, d)) -` {..support_of_segment ((a, b), c, d)}" by (auto simp: list_all_iff normal_of_segment_def support_of_segment_def det3_def' field_simps inner_prod_def ccw'_def) qed moreover have "⋀i. (λn. f n i) ⇢ e i" unfolding f_def by (rule LIMSEQ_minus_fract_mult) hence "(λn. aform_val (f n) X) ⇢ aform_val e X" by (auto simp: aform_val_def pdevs_val_sum intro!: tendsto_intros) ultimately have "aform_val e X ∈ ?cl" by (rule closed_sequentially) thus "det3 (fst ?seg) (snd ?seg) (aform_val e X) ≥ 0" by (auto simp: list_all_iff normal_of_segment_def support_of_segment_def det3_def' field_simps inner_prod_def) qed lemma det3_nonneg_segments_of_aformI: assumes "e ∈ UNIV → {-1 .. 1}" assumes "length (half_segments_of_aform X) ≠ 1" assumes "seg ∈ set (segments_of_aform X)" shows "det3 (fst seg) (snd seg) (aform_val e X) ≥ 0" using assms det3_nonneg_segments_of_aform by (auto simp: list_all_iff) subsection ‹Intersection of Vertical Line with Segment› fun intersect_segment_xline'::"nat ⇒ point * point ⇒ real ⇒ point option" where "intersect_segment_xline' p ((x0, y0), (x1, y1)) xl = (if x0 ≤ xl ∧ xl ≤ x1 then if x0 = x1 then Some ((min y0 y1), (max y0 y1)) else let yl = truncate_down p (truncate_down p (real_divl p (y1 - y0) (x1 - x0) * (xl - x0)) + y0); yr = truncate_up p (truncate_up p (real_divr p (y1 - y0) (x1 - x0) * (xl - x0)) + y0) in Some (yl, yr) else None)" lemma norm_pair_fst0[simp]: "norm (0, x) = norm x" by (auto simp: norm_prod_def) lemmas add_right_mono_le = order_trans[OF add_right_mono] lemmas mult_right_mono_le = order_trans[OF mult_right_mono] lemmas add_right_mono_ge = order_trans[OF _ add_right_mono] lemmas mult_right_mono_ge = order_trans[OF _ mult_right_mono] lemma dest_segment: fixes x b::real assumes "(x, b) ∈ closed_segment (x0, y0) (x1, y1)" assumes "x0 ≠ x1" shows "b = (y1 - y0) * (x - x0) / (x1 - x0) + y0" proof - from assms obtain u where u: "x = x0 *⇩R (1 - u) + u * x1" "b = y0 *⇩R (1 - u) + u * y1" "0 ≤ u" "u ≤ 1" by (auto simp: closed_segment_def algebra_simps) show "b = (y1 - y0) * (x - x0) / (x1 - x0) + y0 " using assms by (auto simp: closed_segment_def field_simps u) qed lemma intersect_segment_xline': assumes "intersect_segment_xline' prec (p0, p1) x = Some (m, M)" shows "closed_segment p0 p1 ∩ {p. fst p = x} ⊆ {(x, m) .. (x, M)}" using assms proof (cases p0) case (Pair x0 y0) note p0 = this show ?thesis proof (cases p1) case (Pair x1 y1) note p1 = this { assume "x0 = x1" "x = x1" "m = min y0 y1" "M = max y0 y1" hence ?thesis by (force simp: abs_le_iff p0 p1 min_def max_def algebra_simps dest: segment_bound split: if_split_asm) } thus ?thesis using assms by (auto simp: abs_le_iff p0 p1 split: if_split_asm intro!: truncate_up_le truncate_down_le add_right_mono_le[OF truncate_down] add_right_mono_le[OF real_divl] add_right_mono_le[OF mult_right_mono_le[OF real_divl]] add_right_mono_ge[OF _ truncate_up] add_right_mono_ge[OF _ mult_right_mono_ge[OF _ real_divr]] dest!: dest_segment) qed qed lemma in_segment_fst_le: fixes x0 x1 b::real assumes "x0 ≤ x1" "(x, b) ∈ closed_segment (x0, y0) (x1, y1)" shows "x ≤ x1" using assms using mult_left_mono[OF ‹x0 ≤ x1›, where c="1 - u" for u] by (force simp add: min_def max_def split: if_split_asm simp add: algebra_simps not_le closed_segment_def) lemma in_segment_fst_ge: fixes x0 x1 b::real assumes "x0 ≤ x1" "(x, b) ∈ closed_segment (x0, y0) (x1, y1)" shows "x0 ≤ x" using assms using mult_left_mono[OF ‹x0 ≤ x1›] by (force simp add: min_def max_def split: if_split_asm simp add: algebra_simps not_le closed_segment_def) lemma intersect_segment_xline'_eq_None: assumes "intersect_segment_xline' prec (p0, p1) x = None" assumes "fst p0 ≤ fst p1" shows "closed_segment p0 p1 ∩ {p. fst p = x} = {}" using assms by (cases p0, cases p1) (auto simp: abs_le_iff split: if_split_asm dest: in_segment_fst_le in_segment_fst_ge) fun intersect_segment_xline where "intersect_segment_xline prec ((a, b), (c, d)) x = (if a ≤ c then intersect_segment_xline' prec ((a, b), (c, d)) x else intersect_segment_xline' prec ((c, d), (a, b)) x)" lemma closed_segment_commute: "closed_segment a b = closed_segment b a" by (meson convex_contains_segment convex_closed_segment dual_order.antisym ends_in_segment) lemma intersect_segment_xline: assumes "intersect_segment_xline prec (p0, p1) x = Some (m, M)" shows "closed_segment p0 p1 ∩ {p. fst p = x} ⊆ {(x, m) .. (x, M)}" using assms by (cases p0, cases p1) (auto simp: closed_segment_commute split: if_split_asm simp del: intersect_segment_xline'.simps dest!: intersect_segment_xline') lemma intersect_segment_xline_fst_snd: assumes "intersect_segment_xline prec seg x = Some (m, M)" shows "closed_segment (fst seg) (snd seg) ∩ {p. fst p = x} ⊆ {(x, m) .. (x, M)}" using intersect_segment_xline[of prec "fst seg" "snd seg" x m M] assms by simp lemma intersect_segment_xline_eq_None: assumes "intersect_segment_xline prec (p0, p1) x = None" shows "closed_segment p0 p1 ∩ {p. fst p = x} = {}" using assms by (cases p0, cases p1) (auto simp: closed_segment_commute split: if_split_asm simp del: intersect_segment_xline'.simps dest!: intersect_segment_xline'_eq_None) lemma inter_image_empty_iff: "(X ∩ {p. f p = x} = {}) ⟷ (x ∉ f ` X)" by auto lemma fst_closed_segment[simp]: "fst ` closed_segment a b = closed_segment (fst a) (fst b)" by (force simp: closed_segment_def) lemma intersect_segment_xline_eq_empty: fixes p0 p1::"real * real" assumes "closed_segment p0 p1 ∩ {p. fst p = x} = {}" shows "intersect_segment_xline prec (p0, p1) x = None" using assms by (cases p0, cases p1) (auto simp: inter_image_empty_iff closed_segment_eq_real_ivl split: if_split_asm) lemma intersect_segment_xline_le: assumes "intersect_segment_xline prec y xl = Some (m0, M0)" shows "m0 ≤ M0" using assms by (cases y) (auto simp: min_def split: if_split_asm intro!: truncate_up_le truncate_down_le order_trans[OF real_divl] order_trans[OF _ real_divr] mult_right_mono) lemma intersect_segment_xline_None_iff: fixes p0 p1::"real * real" shows "intersect_segment_xline prec (p0, p1) x = None ⟷ closed_segment p0 p1 ∩ {p. fst p = x} = {}" by (auto intro!: intersect_segment_xline_eq_empty dest!: intersect_segment_xline_eq_None) subsection ‹Bounds on Vertical Intersection with Oriented List of Segments› primrec bound_intersect_2d where "bound_intersect_2d prec [] x = None" | "bound_intersect_2d prec (X # Xs) xl = (case bound_intersect_2d prec Xs xl of None ⇒ intersect_segment_xline prec X xl | Some (m, M) ⇒ (case intersect_segment_xline prec X xl of None ⇒ Some (m, M) | Some (m', M') ⇒ Some (min m' m, max M' M)))" lemma bound_intersect_2d_eq_None: assumes "bound_intersect_2d prec Xs x = None" assumes "X ∈ set Xs" shows "intersect_segment_xline prec X x = None" using assms by (induct Xs) (auto split: option.split_asm) lemma bound_intersect_2d_upper: assumes "bound_intersect_2d prec Xs x = Some (m, M)" obtains X m' where "X ∈ set Xs" "intersect_segment_xline prec X x = Some (m', M)" "⋀X m' M' . X ∈ set Xs ⟹ intersect_segment_xline prec X x = Some (m', M') ⟹ M' ≤ M" proof atomize_elim show "∃X m'. X ∈ set Xs ∧ intersect_segment_xline prec X x = Some (m', M) ∧ (∀X m' M'. X ∈ set Xs ⟶ intersect_segment_xline prec X x = Some (m', M') ⟶ M' ≤ M)" using assms proof (induct Xs arbitrary: m M) case Nil thus ?case by (simp add: bound_intersect_2d_def) next case (Cons X Xs) show ?case proof (cases "bound_intersect_2d prec Xs x") case None thus ?thesis using Cons by (intro exI[where x=X] exI[where x=m]) (simp del: intersect_segment_xline.simps add: bound_intersect_2d_eq_None) next case (Some mM) note Some1=this then obtain m' M' where mM: "mM = (m', M')" by (cases mM) from Cons(1)[OF Some[unfolded mM]] obtain X' m'' where X': "X' ∈ set Xs" and m'': "intersect_segment_xline prec X' x = Some (m'', M')" and max: "⋀X m' M'a. X ∈ set Xs ⟹ intersect_segment_xline prec X x = Some (m', M'a) ⟹ M'a ≤ M'" by auto show ?thesis proof (cases "intersect_segment_xline prec X x") case None thus ?thesis using Some1 mM Cons(2) X' m'' max by (intro exI[where x= X'] exI[where x= m'']) (auto simp del: intersect_segment_xline.simps split: option.split_asm) next case (Some mM''') thus ?thesis using Some1 mM Cons(2) X' m'' by (cases mM''') (force simp: max_def min_def simp del: intersect_segment_xline.simps split: option.split_asm if_split_asm dest!: max intro!: exI[where x= "if M' ≥ snd mM''' then X' else X"] exI[where x= "if M' ≥ snd mM''' then m'' else fst mM'''"]) qed qed qed qed lemma bound_intersect_2d_lower: assumes "bound_intersect_2d prec Xs x = Some (m, M)" obtains X M' where "X ∈ set Xs" "intersect_segment_xline prec X x = Some (m, M')" "⋀X m' M' . X ∈ set Xs ⟹ intersect_segment_xline prec X x = Some (m', M') ⟹ m ≤ m'" proof atomize_elim show "∃X M'. X ∈ set Xs ∧ intersect_segment_xline prec X x = Some (m, M') ∧ (∀X m' M'. X ∈ set Xs ⟶ intersect_segment_xline prec X x = Some (m', M') ⟶ m ≤ m')" using assms proof (induct Xs arbitrary: m M) case Nil thus ?case by (simp add: bound_intersect_2d_def) next case (Cons X Xs) show ?case proof (cases "bound_intersect_2d prec Xs x") case None thus ?thesis using Cons by (intro exI[where x= X]) (simp del: intersect_segment_xline.simps add: bound_intersect_2d_eq_None) next case (Some mM) note Some1=this then obtain m' M' where mM: "mM = (m', M')" by (cases mM) from Cons(1)[OF Some[unfolded mM]] obtain X' M'' where X': "X' ∈ set Xs" and M'': "intersect_segment_xline prec X' x = Some (m', M'')" and min: "⋀X m'a M'. X ∈ set Xs ⟹ intersect_segment_xline prec X x = Some (m'a, M') ⟹ m' ≤ m'a" by auto show ?thesis proof (cases "intersect_segment_xline prec X x") case None thus ?thesis using Some1 mM Cons(2) X' M'' min by (intro exI[where x= X'] exI[where x= M'']) (auto simp del: intersect_segment_xline.simps split: option.split_asm) next case (Some mM''') thus ?thesis using Some1 mM Cons(2) X' M'' min by (cases mM''') (force simp: max_def min_def simp del: intersect_segment_xline.simps split: option.split_asm if_split_asm dest!: min intro!: exI[where x= "if m' ≤ fst mM''' then X' else X"] exI[where x= "if m' ≤ fst mM''' then M'' else snd mM'''"]) qed qed qed qed lemma bound_intersect_2d: assumes "bound_intersect_2d prec Xs x = Some (m, M)" shows "(⋃(p1, p2) ∈ set Xs. closed_segment p1 p2) ∩ {p. fst p = x} ⊆ {(x, m) .. (x, M)}" proof (clarsimp, safe) fix b x0 y0 x1 y1 assume H: "((x0, y0), x1, y1) ∈ set Xs" "(x, b) ∈ closed_segment (x0, y0) (x1, y1)" hence "intersect_segment_xline prec ((x0, y0), x1, y1) x ≠ None" by (intro notI) (auto dest!: intersect_segment_xline_eq_None simp del: intersect_segment_xline.simps) then obtain e f where ef: "intersect_segment_xline prec ((x0, y0), x1, y1) x = Some (e, f)" by auto with H have "m ≤ e" by (auto intro: bound_intersect_2d_lower[OF assms]) also have "… ≤ b" using intersect_segment_xline[OF ef] H by force finally show "m ≤ b" . have "b ≤ f" using intersect_segment_xline[OF ef] H by force also have "… ≤ M" using H ef by (auto intro: bound_intersect_2d_upper[OF assms]) finally show "b ≤ M" . qed lemma bound_intersect_2d_eq_None_iff: "bound_intersect_2d prec Xs x = None ⟷ (∀X∈set Xs. intersect_segment_xline prec X x = None)" by (induct Xs) (auto simp: split: option.split_asm) lemma bound_intersect_2d_nonempty: assumes "bound_intersect_2d prec Xs x = Some (m, M)" shows "(⋃(p1, p2) ∈ set Xs. closed_segment p1 p2) ∩ {p. fst p = x} ≠ {}" proof - from assms have "bound_intersect_2d prec Xs x ≠ None" by simp then obtain p1 p2 where "(p1, p2) ∈ set Xs" "intersect_segment_xline prec (p1, p2) x ≠ None" unfolding bound_intersect_2d_eq_None_iff by auto hence "closed_segment p1 p2 ∩ {p. fst p = x} ≠ {}" by (simp add: intersect_segment_xline_None_iff) thus ?thesis using ‹(p1, p2) ∈ set Xs› by auto qed lemma bound_intersect_2d_le: assumes "bound_intersect_2d prec Xs x = Some (m, M)" shows "m ≤ M" proof - from bound_intersect_2d_nonempty[OF assms] bound_intersect_2d[OF assms] show "m ≤ M" by auto qed subsection ‹Bounds on Vertical Intersection with General List of Segments› definition "bound_intersect_2d_ud prec X xl = (case segments_of_aform X of [] ⇒ if fst (fst X) = xl then let m = snd (fst X) in Some (m, m) else None | [x, y] ⇒ intersect_segment_xline prec x xl | xs ⇒ (case bound_intersect_2d prec (filter (λ((x1, y1), x2, y2). x1 < x2) xs) xl of Some (m, M') ⇒ (case bound_intersect_2d prec (filter (λ((x1, y1), x2, y2). x1 > x2) xs) xl of Some (m', M) ⇒ Some (min m m', max M M') | None ⇒ None) | None ⇒ None))" lemma list_cases4: "⋀x P. (x = [] ⟹ P) ⟹ (⋀y. x = [y] ⟹ P) ⟹ (⋀y z. x = [y, z] ⟹ P) ⟹ (⋀w y z zs. x = w # y # z # zs ⟹ P) ⟹ P" by (metis list.exhaust) lemma bound_intersect_2d_ud_segments_of_aform_le: "bound_intersect_2d_ud prec X xl = Some (m0, M0) ⟹ m0 ≤ M0" by (cases "segments_of_aform X" rule: list_cases4) (auto simp: Let_def bound_intersect_2d_ud_def min_def max_def intersect_segment_xline_le if_split_eq1 split: option.split_asm prod.split_asm list.split_asm dest!: bound_intersect_2d_le) lemma pdevs_domain_eq_empty_iff[simp]: "pdevs_domain (snd X) = {} ⟷ snd X = zero_pdevs" by (auto simp: intro!: pdevs_eqI) lemma ccw_contr_on_line_left: assumes "det3 (a, b) (x, c) (x, d) ≥ 0" "a > x" shows "d ≤ c" proof - from assms have "d * (a - x) ≤ c * (a - x)" by (auto simp: det3_def' algebra_simps) with assms show "c ≥ d" by auto qed lemma ccw_contr_on_line_right: assumes "det3 (a, b) (x, c) (x, d) ≥ 0" "a < x" shows "d ≥ c" proof - from assms have "c * (x - a) ≤ d * (x - a)" by (auto simp: det3_def' algebra_simps) with assms show "d ≥ c" by auto qed lemma singleton_contrE: assumes "⋀x y. x ≠ y ⟹ x ∈ X ⟹ y ∈ X ⟹ False" assumes "X ≠ {}" obtains x where "X = {x}" using assms by blast lemma segment_intersection_singleton: fixes xl and a b::"real * real" defines "i ≡ closed_segment a b ∩ {p. fst p = xl}" assumes ne1: "fst a ≠ fst b" assumes upper: "i ≠ {}" obtains p1 where "i = {p1}" proof (rule singleton_contrE[OF _ upper]) fix x y assume H: "x ≠ y" "x ∈ i" "y ∈ i" then obtain u v where uv: "x = u *⇩R b + (1 - u) *⇩R a" "y = v *⇩R b + (1 - v) *⇩R a" "0 ≤ u" "u ≤ 1" "0 ≤ v" "v ≤ 1" by (auto simp add: closed_segment_def i_def field_simps) then have "x + u *⇩R a = a + u *⇩R b" "y + v *⇩R a = a + v *⇩R b" by simp_all then have "fst (x + u *⇩R a) = fst (a + u *⇩R b)" "fst (y + v *⇩R a) = fst (a + v *⇩R b)" by simp_all then have "u = v * (fst a - fst b) / (fst a - fst b)" using ne1 H(2,3) ‹0 ≤ u› ‹u ≤ 1› ‹0 ≤ v› ‹v ≤ 1› by (simp add: closed_segment_def i_def field_simps) then have "u = v" by (simp add: ne1) then show False using H uv by simp qed lemma bound_intersect_2d_ud_segments_of_aform: assumes "bound_intersect_2d_ud prec X xl = Some (m0, M0)" assumes "e ∈ UNIV → {-1 .. 1}" shows "{aform_val e X} ∩ {x. fst x = xl} ⊆ {(xl, m0) .. (xl, M0)}" proof safe fix a b assume safeassms: "(a, b) = aform_val e X" "xl = fst (a, b)" hence fst_aform_val: "fst (aform_val e X) = xl" by simp { assume len: "length (segments_of_aform X) > 2" with assms obtain m M m' M' where lb: "bound_intersect_2d prec [((x1, y1), x2, y2)←segments_of_aform X . x1 < x2] xl = Some (m, M')" and ub: "bound_intersect_2d prec [((x1, y1), x2, y2)←segments_of_aform X . x2 < x1] xl = Some (m', M)" and minmax: "m0 = min m m'" "M0 = max M M'" by (auto simp: bound_intersect_2d_ud_def split: option.split_asm list.split_asm ) from bound_intersect_2d_upper[OF ub] obtain X1 m1 where upper: "X1 ∈ set [((x1, y1), x2, y2)←segments_of_aform X . x2 < x1]" "intersect_segment_xline prec X1 xl = Some (m1, M)" by metis from bound_intersect_2d_lower[OF lb] obtain X2 M2 where lower: "X2 ∈ set [((x1, y1), x2, y2)←segments_of_aform X . x1 < x2]" "intersect_segment_xline prec X2 xl = Some (m, M2)" by metis from upper(1) lower(1) have X1: "X1 ∈ set (segments_of_aform X)" "fst (fst X1) > fst (snd X1)" and X2: "X2 ∈ set (segments_of_aform X)" "fst (fst X2) < fst (snd X2)" by auto note upper_seg = intersect_segment_xline_fst_snd[OF upper(2)] note lower_seg = intersect_segment_xline_fst_snd[OF lower(2)] from len have lh: "length (half_segments_of_aform X) ≠ 1" by (auto simp: segments_of_aform_def Let_def) from X1 have ne1: "fst (fst X1) ≠ fst (snd X1)" by simp moreover have "closed_segment (fst X1) (snd X1) ∩ {p. fst p = xl} ≠ {}" using upper(2) by (simp add: intersect_segment_xline_None_iff[of prec, symmetric]) ultimately obtain p1 where p1: "closed_segment (fst X1) (snd X1) ∩ {p. fst p = xl} = {p1}" by (rule segment_intersection_singleton) then obtain u where u: "p1 = (1 - u) *⇩R fst X1 + u *⇩R (snd X1)" "0 ≤ u" "u ≤ 1" by (auto simp: closed_segment_def algebra_simps) have coll1: "det3 (fst X1) p1 (aform_val e X) ≥ 0" and coll1': "det3 p1 (snd X1) (aform_val e X) ≥ 0" unfolding atomize_conj using u by (cases "u = 0 ∨ u = 1") (auto simp: u(1) intro: det3_nonneg_scaleR_segment1 det3_nonneg_scaleR_segment2 det3_nonneg_segments_of_aformI[OF ‹e ∈ _› lh X1(1)]) from X2 have ne2: "fst (fst X2) ≠ fst (snd X2)" by simp moreover have "closed_segment (fst X2) (snd X2) ∩ {p. fst p = xl} ≠ {}" using lower(2) by (simp add: intersect_segment_xline_None_iff[of prec, symmetric]) ultimately obtain p2 where p2: "closed_segment (fst X2) (snd X2) ∩ {p. fst p = xl} = {p2}" by (rule segment_intersection_singleton) then obtain v where v: "p2 = (1 - v) *⇩R fst X2 + v *⇩R (snd X2)" "0 ≤ v" "v ≤ 1" by (auto simp: closed_segment_def algebra_simps) have coll2: "det3 (fst X2) p2 (aform_val e X) ≥ 0" and coll2': "det3 p2 (snd X2) (aform_val e X) ≥ 0" unfolding atomize_conj using v by (cases "v = 0 ∨ v = 1") (auto simp: v(1) intro: det3_nonneg_scaleR_segment1 det3_nonneg_scaleR_segment2 det3_nonneg_segments_of_aformI[OF ‹e ∈ _› lh X2(1)]) from in_set_segments_of_aform_aform_valE [of "fst X1" "snd X1" X, unfolded prod.collapse, OF X1(1)] obtain e1s where e1s: "snd X1 = aform_val e1s X" "e1s ∈ UNIV → {- 1..1}" . from previous_segments_of_aformE [of "fst X1" "snd X1" X, unfolded prod.collapse, OF X1(1)] obtain fX0 where "(fX0, fst X1) ∈ set (segments_of_aform X)" . from in_set_segments_of_aform_aform_valE[OF this] obtain e1f where e1f: "fst X1 = aform_val e1f X" "e1f ∈ UNIV → {- 1..1}" . have "p1 ∈ closed_segment (aform_val e1f X) (aform_val e1s X)" using p1 by (auto simp: e1s e1f) with segment_in_aform_val[OF e1s(2) e1f(2), of X] obtain ep1 where ep1: "ep1 ∈ UNIV → {-1 .. 1}" "p1 = aform_val ep1 X" by (auto simp: Affine_def valuate_def closed_segment_commute) from in_set_segments_of_aform_aform_valE [of "fst X2" "snd X2" X, unfolded prod.collapse, OF X2(1)] obtain e2s where e2s: "snd X2 = aform_val e2s X" "e2s ∈ UNIV → {- 1..1}" . from previous_segments_of_aformE [of "fst X2" "snd X2" X, unfolded prod.collapse, OF X2(1)] obtain fX02 where "(fX02, fst X2) ∈ set (segments_of_aform X)" . from in_set_segments_of_aform_aform_valE[OF this] obtain e2f where e2f: "fst X2 = aform_val e2f X" "e2f ∈ UNIV → {- 1..1}" . have "p2 ∈ closed_segment (aform_val e2f X) (aform_val e2s X)" using p2 by (auto simp: e2s e2f) with segment_in_aform_val[OF e2f(2) e2s(2), of X] obtain ep2 where ep2: "ep2 ∈ UNIV → {-1 .. 1}" "p2 = aform_val ep2 X" by (auto simp: Affine_def valuate_def) from det3_nonneg_segments_of_aformI[OF ep2(1), of X "(fst X1, snd X1)", unfolded prod.collapse, OF lh X1(1), unfolded ep2(2)[symmetric]] have c2: "det3 (fst X1) (snd X1) p2 ≥ 0" . hence c12: "det3 (fst X1) p1 p2 ≥ 0" using u by (cases "u = 0") (auto simp: u(1) det3_nonneg_scaleR_segment2) from det3_nonneg_segments_of_aformI[OF ep1(1), of X "(fst X2, snd X2)", unfolded prod.collapse, OF lh X2(1), unfolded ep1(2)[symmetric]] have c1: "det3 (fst X2) (snd X2) p1 ≥ 0" . hence c21: "det3 (fst X2) p2 p1 ≥ 0" using v by (cases "v = 0") (auto simp: v(1) det3_nonneg_scaleR_segment2) from p1 p2 have p1p2xl: "fst p1 = xl" "fst p2 = xl" by (auto simp: det3_def') from upper_seg p1 have "snd p1 ≤ M" by (auto simp: less_eq_prod_def) from lower_seg p2 have "m ≤ snd p2" by (auto simp: less_eq_prod_def) { have *: "(fst p1, snd (aform_val e X)) = aform_val e X" by (simp add: prod_eq_iff p1p2xl fst_aform_val) hence coll: "det3 (fst (fst X1), snd (fst X1)) (fst p1, snd p1) (fst p1, snd (aform_val e X)) ≥ 0" and coll': "det3 (fst (snd X1), snd (snd X1)) (fst p1, snd (aform_val e X)) (fst p1, snd p1) ≥ 0" using coll1 coll1' by (auto simp: det3_rotate) have "snd (aform_val e X) ≤ M" proof (cases "fst (fst X1) = xl") case False have "fst (fst X1) ≥ fst p1" unfolding u using X1 by (auto simp: algebra_simps intro!: mult_left_mono u) moreover have "fst (fst X1) ≠ fst p1" using False by (simp add: p1p2xl) ultimately have "fst (fst X1) > fst p1" by simp from ccw_contr_on_line_left[OF coll this] show ?thesis using ‹snd p1 ≤ M› by simp next case True have "fst (snd X1) * (1 - u) ≤ fst (fst X1) * (1 - u)" using X1 u by (auto simp: intro!: mult_right_mono) hence "fst (snd X1) ≤ fst p1" unfolding u by (auto simp: algebra_simps) moreover have "fst (snd X1) ≠ fst p1" using True ne1 by (simp add: p1p2xl) ultimately have "fst (snd X1) < fst p1" by simp from ccw_contr_on_line_right[OF coll' this] show ?thesis using ‹snd p1 ≤ M› by simp qed } moreover { have "(fst p2, snd (aform_val e X)) = aform_val e X" by (simp add: prod_eq_iff p1p2xl fst_aform_val) hence coll: "det3 (fst (fst X2), snd (fst X2)) (fst p2, snd p2) (fst p2, snd (aform_val e X)) ≥ 0" and coll': "det3 (fst (snd X2), snd (snd X2)) (fst p2, snd (aform_val e X)) (fst p2, snd p2) ≥ 0" using coll2 coll2' by (auto simp: det3_rotate) have "m ≤ snd (aform_val e X)" proof (cases "fst (fst X2) = xl") case False have "fst (fst X2) ≤ fst p2" unfolding v using X2 by (auto simp: algebra_simps intro!: mult_left_mono v) moreover have "fst (fst X2) ≠ fst p2" using False by (simp add: p1p2xl) ultimately have "fst (fst X2) < fst p2" by simp from ccw_contr_on_line_right[OF coll this] show ?thesis using ‹m ≤ snd p2› by simp next case True have "(1 - v) * fst (snd X2) ≥ (1 - v) * fst (fst X2)" using X2 v by (auto simp: intro!: mult_left_mono) hence "fst (snd X2) ≥ fst p2" unfolding v by (auto simp: algebra_simps) moreover have "fst (snd X2) ≠ fst p2" using True ne2 by (simp add: p1p2xl) ultimately have "fst (snd X2) > fst p2" by simp from ccw_contr_on_line_left[OF coll' this] show ?thesis using ‹m ≤ snd p2› by simp qed } ultimately have "aform_val e X ∈ {(xl, m) .. (xl, M)}" by (auto simp: less_eq_prod_def fst_aform_val) hence "aform_val e X ∈ {(xl, m0) .. (xl, M0)}" by (auto simp: minmax less_eq_prod_def) } moreover { assume "length (segments_of_aform X) = 2" then obtain a b where s: "segments_of_aform X = [a, b]" by (auto simp: numeral_2_eq_2 length_Suc_conv) from segments_of_aform_line_segment[OF this assms(2)] have "aform_val e X ∈ closed_segment (fst a) (snd a)" . moreover from assms have "intersect_segment_xline prec a xl = Some (m0, M0)" by (auto simp: bound_intersect_2d_ud_def s) note intersect_segment_xline_fst_snd[OF this] ultimately have "aform_val e X ∈ {(xl, m0) .. (xl, M0)}" by (auto simp: less_eq_prod_def fst_aform_val) } moreover { assume "length (segments_of_aform X) = 1" from polychain_of_segments_of_aform1[OF this] have "aform_val e X ∈ {(xl, m0) .. (xl, M0)}" by auto } moreover { assume len: "length (segments_of_aform X) = 0" hence "independent_pdevs (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = []" by (simp add: segments_of_aform_def Let_def half_segments_of_aform_def inl_def) hence "snd X = zero_pdevs" by (subst (asm) independent_pdevs_eq_Nil_iff) (auto simp: list_all_iff list_of_pdevs_def) hence "aform_val e X = fst X" by (simp add: aform_val_def) with len assms have "aform_val e X ∈ {(xl, m0) .. (xl, M0)}" by (auto simp: bound_intersect_2d_ud_def Let_def split: if_split_asm) } ultimately have "aform_val e X ∈ {(xl, m0)..(xl, M0)}" by arith thus "(a, b) ∈ {(fst (a, b), m0)..(fst (a, b), M0)}" using safeassms by simp qed subsection ‹Approximation from Orthogonal Directions› definition inter_aform_plane_ortho:: "nat ⇒ 'a::executable_euclidean_space aform ⇒ 'a ⇒ real ⇒ 'a aform option" where "inter_aform_plane_ortho p Z n g = do { mMs ← those (map (λb. bound_intersect_2d_ud p (inner2_aform Z n b) g) Basis_list); let l = (∑(b, m)←zip Basis_list (map fst mMs). m *⇩R b); let u = (∑(b, M)←zip Basis_list (map snd mMs). M *⇩R b); Some (aform_of_ivl l u) }" lemma those_eq_SomeD: assumes "those (map f xs) = Some ys" shows "ys = map (the o f) xs ∧ (∀i.∃y. i < length xs ⟶ f (xs ! i) = Some y)" using assms by (induct xs arbitrary: ys) (auto split: option.split_asm simp: o_def nth_Cons split: nat.split) lemma sum_list_zip_map: assumes "distinct xs" shows "(∑(x, y)←zip xs (map g xs). f x y) = (∑x∈set xs. f x (g x))" by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta' in_set_zip in_set_conv_nth inj_on_convol_ident intro!: sum.reindex_cong[where l="λx. (x, g x)"]) lemma inter_aform_plane_ortho_overappr: assumes "inter_aform_plane_ortho p Z n g = Some X" shows "{x. ∀i ∈ Basis. x ∙ i ∈ {y. (g, y) ∈ (λx. (x ∙ n, x ∙ i)) ` Affine Z}} ⊆ Affine X" proof - let ?inter = "(λb. bound_intersect_2d_ud p (inner2_aform Z n b) g)" obtain xs where xs: "those (map ?inter Basis_list) = Some xs" using assms by (cases "those (map ?inter Basis_list)") (auto simp: inter_aform_plane_ortho_def) from those_eq_SomeD[OF this] obtain y' where xs_eq: "xs = map (the ∘ ?inter) Basis_list" and y': "⋀i. i < length (Basis_list::'a list) ⟹ ?inter (Basis_list ! i) = Some (y' i)" by metis have "∀(i::'a) ∈ Basis. ∃j<length (Basis_list::'a list). i = Basis_list ! j" by (metis Basis_list in_set_conv_nth) then obtain j where j: "⋀i::'a. i∈Basis ⟹ j i < length (Basis_list::'a list)" "⋀i::'a. i∈Basis ⟹ i = Basis_list ! j i" by metis define y where "y = y' o j" with y' j have y: "⋀i. i ∈ Basis ⟹ ?inter i = Some (y i)" by (metis comp_def) hence y_le: "⋀i. i ∈ Basis ⟹ fst (y i) ≤ snd (y i)" by (auto intro!: bound_intersect_2d_ud_segments_of_aform_le) hence "(∑b∈Basis. fst (y b) *⇩R b) ≤ (∑b∈Basis. snd (y b) *⇩R b)" by (auto simp: eucl_le[where 'a='a]) with assms have X: "Affine X = {∑b∈Basis. fst (y b) *⇩R b..∑b∈Basis. snd (y b) *⇩R b}" by (auto simp: inter_aform_plane_ortho_def sum_list_zip_map xs xs_eq y Affine_aform_of_ivl) show ?thesis proof safe fix x assume x: "∀i∈Basis. x ∙ i ∈ {y. (g, y) ∈ (λx. (x ∙ n, x ∙ i)) ` Affine Z}" { fix i::'a assume i: "i ∈ Basis" from x i have x_in2: "(g, x ∙ i) ∈ (λx. (x ∙ n, x ∙ i)) ` Affine Z" by auto from x_in2 obtain e where e: "e ∈ UNIV → {- 1..1}" and g: "g = aform_val e Z ∙ n" and x: "x ∙ i = aform_val e Z ∙ i" by (auto simp: Affine_def valuate_def) have "{aform_val e (inner2_aform Z n i)} = {aform_val e (inner2_aform Z n i)} ∩ {x. fst x = g}" by (auto simp: g inner2_def) also from y[OF ‹i ∈ Basis›] have "?inter i = Some (fst (y i), snd (y i))" by simp note bound_intersect_2d_ud_segments_of_aform[OF this e] finally have "x ∙ i ∈ {fst (y i) .. snd (y i)}" by (auto simp: x inner2_def) } thus "x ∈ Affine X" unfolding X by (auto simp: eucl_le[where 'a='a]) qed qed lemma inter_proj_eq: fixes n g l defines "G ≡ {x. x ∙ n = g}" shows "(λx. x ∙ l) ` (Z ∩ G) = {y. (g, y) ∈ (λx. (x ∙ n, x ∙ l)) ` Z}" by (auto simp: G_def) lemma inter_overappr: fixes n γ l shows "Z ∩ {x. x ∙ n = g} ⊆ {x. ∀i ∈ Basis. x ∙ i ∈ {y. (g, y) ∈ (λx. (x ∙ n, x ∙ i)) ` Z}}" by auto lemma inter_inter_aform_plane_ortho: assumes "inter_aform_plane_ortho p Z n g = Some X" shows "Affine Z ∩ {x. x ∙ n = g} ⊆ Affine X" proof - note inter_overappr[of "Affine Z" n g] also note inter_aform_plane_ortho_overappr[OF assms] finally show ?thesis . qed subsection ‹``Completeness'' of Intersection› abbreviation "encompasses x seg ≡ det3 (fst seg) (snd seg) x ≥ 0" lemma encompasses_cases: "encompasses x seg ∨ encompasses x (snd seg, fst seg)" by (auto simp: det3_def' algebra_simps) lemma list_all_encompasses_cases: assumes "list_all (encompasses p) (x # y # zs)" obtains "list_all (encompasses p) [x, y, (snd y, fst x)]" | "list_all (encompasses p) ((fst x, snd y)#zs)" using encompasses_cases proof assume "encompasses p (snd y, fst x)" hence "list_all (encompasses p) [x, y, (snd y, fst x)]" using assms by (auto simp: list_all_iff) thus ?thesis .. next assume "encompasses p (snd (snd y, fst x), fst (snd y, fst x))" hence "list_all (encompasses p) ((fst x, snd y)#zs)" using assms by (auto simp: list_all_iff) thus ?thesis .. qed lemma triangle_encompassing_polychain_of: assumes "det3 p a b ≥ 0" "det3 p b c ≥ 0" "det3 p c a ≥ 0" assumes "ccw' a b c" shows "p ∈ convex hull {a, b, c}" proof - from assms have nn: "det3 b c p ≥ 0" "det3 c a p ≥ 0" "det3 a b p ≥ 0" "det3 a b c ≥ 0" by (auto simp: det3_def' algebra_simps) have "det3 a b c *⇩R p = det3 b c p *⇩R a + det3 c a p *⇩R b + det3 a b p *⇩R c" by (auto simp: det3_def' algebra_simps prod_eq_iff) hence "inverse (det3 a b c) *⇩R (det3 a b c *⇩R p) = inverse (det3 a b c) *⇩R (det3 b c p *⇩R a + det3 c a p *⇩R b + det3 a b p *⇩R c)" by simp with assms have p_eq: "p = (det3 b c p / det3 a b c) *⇩R a + (det3 c a p / det3 a b c) *⇩R b + (det3 a b p / det3 a b c) *⇩R c" (is "_ = scaleR ?u _ + scaleR ?v _ + scaleR ?w _") by (simp add: inverse_eq_divide algebra_simps ccw'_def) have det_eq: "det3 b c p / det3 a b c + det3 c a p / det3 a b c + det3 a b p / det3 a b c = 1" using assms(4) by (simp add: add_divide_distrib[symmetric] det3_def' algebra_simps ccw'_def) show ?thesis unfolding convex_hull_3 using assms(4) by (blast intro: exI[where x="?u"] exI[where x="?v"] exI[where x="?w"] intro!: p_eq divide_nonneg_nonneg nn det_eq) qed lemma encompasses_convex_polygon3: assumes "list_all (encompasses p) (x#y#z#zs)" assumes "convex_polygon (x#y#z#zs)" assumes "ccw'.sortedP (fst x) (map snd (butlast (x#y#z#zs)))" shows "p ∈ convex hull (set (map fst (x#y#z#zs)))" using assms proof (induct zs arbitrary: x y z p) case Nil thus ?case by (auto simp: det3_def' algebra_simps elim!: ccw'.sortedP_Cons ccw'.sortedP_Nil intro!: triangle_encompassing_polychain_of) next case (Cons w ws) from Cons.prems(2) have "snd y = fst z" by auto from Cons.prems(1) show ?case proof (rule list_all_encompasses_cases) assume "list_all (encompasses p) [x, y, (snd y, fst x)]" hence "p ∈ convex hull {fst x, fst y, snd y}" using Cons.prems by (auto simp: det3_def' algebra_simps elim!: ccw'.sortedP_Cons ccw'.sortedP_Nil intro!: triangle_encompassing_polychain_of) thus ?case by (rule rev_subsetD[OF _ hull_mono]) (auto simp: ‹snd y = fst z›) next assume *: "list_all (encompasses p) ((fst x, snd y) # z # w # ws)" from Cons.prems have enc: "ws ≠ [] ⟹ encompasses p (last ws)" by (auto simp: list_all_iff) have "set (map fst ((fst x, snd y)#z#w#ws)) ⊆ set (map fst (x # y # z # w # ws))" by auto moreover { note * moreover have "convex_polygon ((fst x, snd y) # z # w # ws)" by (metis convex_polygon_skip Cons.prems(2,3)) moreover have "ccw'.sortedP (fst (fst x, snd y)) (map snd (butlast ((fst x, snd y) # z # w # ws)))" using Cons.prems(3) by (auto elim!: ccw'.sortedP_Cons intro!: ccw'.sortedP.Cons ccw'.sortedP.Nil split: if_split_asm) ultimately have "p ∈ convex hull set (map fst ((fst x, snd y)#z#w#ws))" by (rule Cons.hyps) } ultimately show "p ∈ convex hull set (map fst (x # y # z # w # ws))" by (rule subsetD[OF hull_mono]) qed qed lemma segments_of_aform_empty_Affine_eq: assumes "segments_of_aform X = []" shows "Affine X = {fst X}" proof - have "independent_pdevs (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = [] ⟷ (list_of_pdevs (nlex_pdevs (snd X))) = []" by (subst independent_pdevs_eq_Nil_iff) (auto simp: list_all_iff list_of_pdevs_def ) with assms show ?thesis by (force simp: aform_val_def list_of_pdevs_def Affine_def valuate_def segments_of_aform_def Let_def half_segments_of_aform_def inl_def) qed lemma not_segments_of_aform_singleton: "segments_of_aform X ≠ [x]" by (auto simp: segments_of_aform_def Let_def add_is_1 dest!: arg_cong[where f=length]) lemma encompasses_segments_of_aform_in_AffineI: assumes "length (segments_of_aform X) > 2" assumes "list_all (encompasses p) (segments_of_aform X)" shows "p ∈ Affine X" proof - from assms(1) obtain x y z zs where eq: "segments_of_aform X = x#y#z#zs" by (cases "segments_of_aform X" rule: list_cases4) auto hence "fst x = fst (hd (half_segments_of_aform X))" by (metis segments_of_aform_def hd_append list.map_disc_iff list.sel(1)) also have "… = lowest_vertex (fst X, nlex_pdevs (snd X))" using assms by (intro fst_hd_half_segments_of_aform) (auto simp: segments_of_aform_def) finally have fstx: "fst x = lowest_vertex (fst X, nlex_pdevs (snd X))" . have "p ∈ convex hull (set (map fst (segments_of_aform X)))" using assms(2) unfolding eq proof (rule encompasses_convex_polygon3) show "convex_polygon (x # y # z # zs)" using assms(1) unfolding eq[symmetric] by (intro convex_polygon_segments_of_aform) (simp add: segments_of_aform_def Let_def) show "ccw'.sortedP (fst x) (map snd (butlast (x # y # z # zs)))" using assms(1) unfolding fstx map_butlast eq[symmetric] by (intro ccw'_sortedP_snd_segments_of_aform) (simp add: segments_of_aform_def Let_def half_segments_of_aform_def) qed also have "… ⊆ convex hull (Affine X)" proof (rule hull_mono, safe) fix a b assume "(a, b) ∈ set (map fst (segments_of_aform X))" then obtain c d where "((a, b), c, d) ∈ set (segments_of_aform X)" by auto from previous_segments_of_aformE[OF this] obtain x where "(x, a, b) ∈ set (segments_of_aform X)" by auto from in_set_segments_of_aform_aform_valE[OF this] obtain e where "(a, b) = aform_val e X" "e ∈ UNIV → {- 1..1}" by auto thus "(a, b) ∈ Affine X" by (auto simp: Affine_def valuate_def image_iff) qed also have "… = Affine X" by (simp add: convex_Affine convex_hull_eq) finally show ?thesis . qed end
section ‹Implementation› theory Affine_Code imports Affine_Approximation Intersection begin text ‹Implementing partial deviations as sorted lists of coefficients.› subsection ‹Reverse Sorted, Distinct Association Lists› typedef (overloaded) ('a, 'b) slist = "{xs::('a::linorder × 'b) list. distinct (map fst xs) ∧ sorted (rev (map fst xs))}" by (auto intro!: exI[where x="[]"]) setup_lifting type_definition_slist lift_definition map_of_slist::"(nat, 'a::zero) slist ⇒ nat ⇒ 'a option" is map_of . lemma finite_dom_map_of_slist[intro, simp]: "finite (dom (map_of_slist xs))" by transfer (auto simp: finite_dom_map_of) abbreviation "the_default a x ≡ (case x of None ⇒ a | Some b ⇒ b)" definition "Pdevs_raw xs i = the_default 0 (map_of xs i)" lemma nonzeros_Pdevs_raw_subset: "{i. Pdevs_raw xs i ≠ 0} ⊆ dom (map_of xs)" unfolding Pdevs_raw_def[abs_def] by transfer (auto simp: Pdevs_raw_def split: option.split_asm) lift_definition Pdevs::"(nat, 'a::zero) slist ⇒ 'a pdevs" is Pdevs_raw by (rule finite_subset[OF nonzeros_Pdevs_raw_subset]) (simp add: finite_dom_map_of) code_datatype Pdevs subsection ‹Degree› primrec degree_list::"(nat × 'a::zero) list ⇒ nat" where "degree_list [] = 0" | "degree_list (x#xs) = (if snd x = 0 then degree_list xs else Suc (fst x))" lift_definition degree_slist::"(nat, 'a::zero) slist ⇒ nat" is degree_list . lemma degree_list_eq_zeroD: assumes "degree_list xs = 0" shows "the_default 0 (map_of xs i) = 0" using assms by (induct xs) (auto simp: Pdevs_raw_def sorted_append split: if_split_asm) lemma degree_slist_eq_zeroD: "degree_slist xs = 0 ⟹ degree (Pdevs xs) = 0" unfolding degree_eq_Suc_max by transfer (auto dest: degree_list_eq_zeroD simp: Pdevs_raw_def) lemma degree_slist_eq_SucD: "degree_slist xs = Suc n ⟹ pdevs_apply (Pdevs xs) n ≠ 0" proof (transfer, goal_cases) case (1 xs n) thus ?case by (induct xs) (auto simp: Pdevs_raw_def sorted_append map_of_eq_None_iff[symmetric] split: if_split_asm option.split_asm) qed lemma degree_slist_zero: "degree_slist xs = n ⟹ n ≤ j ⟹ pdevs_apply (Pdevs xs) j = 0" proof (transfer, goal_cases) case (1 xs n j) thus ?case by (induct xs) (auto simp: Pdevs_raw_def sorted_append split: if_split_asm option.split) qed lemma compute_degree[code]: "degree (Pdevs xs) = degree_slist xs" by (cases "degree_slist xs") (auto dest: degree_slist_eq_zeroD degree_slist_eq_SucD intro!: degree_eqI degree_slist_zero) subsection ‹Auxiliary Definitions› fun binop where "binop f z1 z2 [] [] = []" | "binop f z1 z2 ((i, x)#xs) [] = (i, f x z2) # binop f z1 z2 xs []" | "binop f z1 z2 [] ((i, y)#ys) = (i, f z1 y) # binop f z1 z2 [] ys" | "binop f z1 z2 ((i, x)#xs) ((j, y)#ys) = (if (i = j) then (i, f x y) # binop f z1 z2 xs ys else if (i > j) then (i, f x z2) # binop f z1 z2 xs ((j, y)#ys) else (j, f z1 y) # binop f z1 z2 ((i, x)#xs) ys)" lemma set_binop_elemD1: "(a, b) ∈ set (binop f z1 z2 xs ys) ⟹ (a ∈ set (map fst xs) ∨ a ∈ set (map fst ys))" by (induct f z1 z2 xs ys rule: binop.induct) (auto split: if_split_asm) lemma set_binop_elemD2: "(a, b) ∈ set (binop f z1 z2 xs ys) ⟹ (∃x∈set (map snd xs). b = f x z2) ∨ (∃y∈set (map snd ys). b = f z1 y) ∨ (∃x∈set (map snd xs). ∃y∈set (map snd ys). b = f x y)" by (induct f z1 z2 xs ys rule: binop.induct) (auto split: if_split_asm) abbreviation "rsorted≡λx. sorted (rev x)" lemma rsorted_binop: fixes xs::"('a::linorder * 'b) list" and ys::"('a::linorder * 'c) list" assumes "rsorted ((map fst xs))" assumes "rsorted ((map fst ys))" shows "rsorted ((map fst (binop f z1 z2 xs ys)))" using assms by (induct f z1 z2 xs ys rule: binop.induct) (force simp: sorted_append dest!: set_binop_elemD1)+ lemma distinct_binop: fixes xs::"('a::linorder * 'b) list" and ys::"('a::linorder * 'c) list" assumes "distinct (map fst xs)" assumes "distinct (map fst ys)" assumes "rsorted ((map fst xs))" assumes "rsorted ((map fst ys))" shows "distinct (map fst (binop f z1 z2 xs ys))" using assms by (induct f z1 z2 xs ys rule: binop.induct) (force dest!: set_binop_elemD1 simp: sorted_append)+ lemma binop_plus: fixes b::"(nat * 'a::euclidean_space) list" shows "(∑(i, y)←binop (+) 0 0 b ba. e i *⇩R y) = (∑(i, y)←b. e i *⇩R y) + (∑(i, y)←ba. e i *⇩R y)" by (induct "(+) ::'a⇒_" "0::'a" "0::'a" b ba rule: binop.induct) (auto simp: algebra_simps) lemma binop_compose: "binop (λx y. f (g x y)) z1 z2 xs ys = map (apsnd f) (binop g z1 z2 xs ys)" by (induct "λx y. f (g x y)" z1 z2 xs ys rule: binop.induct) auto lemma linear_cmul_left[intro, simp]: "linear ((*) x::real ⇒ _)" by (auto intro!: linearI simp: algebra_simps) lemma length_merge_sorted_eq: "length (binop f z1 z2 xs ys) = length (binop g y1 y2 xs ys)" by (induction f z1 z2 xs ys rule: binop.induct) auto subsection ‹Pointswise Addition› lift_definition add_slist::"(nat, 'a::{plus, zero}) slist ⇒ (nat, 'a) slist ⇒ (nat, 'a) slist" is "λxs ys. binop (+) 0 0 xs ys" by (auto simp: intro!: distinct_binop rsorted_binop) lemma map_of_binop[simp]: "rsorted (map fst xs) ⟹ rsorted (map fst ys) ⟹ distinct (map fst xs) ⟹ distinct (map fst ys) ⟹ map_of (binop f z1 z2 xs ys) i = (case map_of xs i of Some x ⇒ Some (f x (case map_of ys i of Some x ⇒ x | None ⇒ z2)) | None ⇒ (case map_of ys i of Some y ⇒ Some (f z1 y) | None ⇒ None))" by (induct f z1 z2 xs ys rule: binop.induct) (auto split: option.split option.split_asm simp: sorted_append) lemma pdevs_apply_Pdevs_add_slist[simp]: fixes xs ys::"(nat, 'a::monoid_add) slist" shows "pdevs_apply (Pdevs (add_slist xs ys)) i = pdevs_apply (Pdevs xs) i + pdevs_apply (Pdevs ys) i" by (transfer) (auto simp: Pdevs_raw_def split: option.split) lemma compute_add_pdevs[code]: "add_pdevs (Pdevs xs) (Pdevs ys) = Pdevs (add_slist xs ys)" by (rule pdevs_eqI) simp subsection ‹prod of pdevs› lift_definition prod_slist::"(nat, 'a::zero) slist ⇒ (nat, 'b::zero) slist ⇒ (nat, ('a × 'b)) slist" is "λxs ys. binop Pair 0 0 xs ys" by (auto simp: intro!: distinct_binop rsorted_binop) lemma pdevs_apply_Pdevs_prod_slist[simp]: "pdevs_apply (Pdevs (prod_slist xs ys)) i = (pdevs_apply (Pdevs xs) i, pdevs_apply (Pdevs ys) i)" by transfer (auto simp: Pdevs_raw_def zero_prod_def split: option.splits) lemma compute_prod_of_pdevs[code]: "prod_of_pdevs (Pdevs xs) (Pdevs ys) = Pdevs (prod_slist xs ys)" by (rule pdevs_eqI) simp subsection ‹Set of Coefficients› lift_definition set_slist::"(nat, 'a::real_vector) slist ⇒ (nat * 'a) set" is set . lemma finite_set_slist[intro, simp]: "finite (set_slist xs)" by transfer simp subsection ‹Domain› lift_definition list_of_slist::"('a::linorder, 'b::zero) slist ⇒ ('a * 'b) list" is "λxs. filter (λx. snd x ≠ 0) xs" . lemma compute_pdevs_domain[code]: "pdevs_domain (Pdevs xs) = set (map fst (list_of_slist xs))" unfolding pdevs_domain_def by transfer (force simp: Pdevs_raw_def split: option.split_asm) lemma sort_rev_eq_sort: "distinct xs ⟹ sort (rev xs) = sort xs" by (rule sorted_distinct_set_unique) auto lemma compute_list_of_pdevs[code]: "list_of_pdevs (Pdevs xs) = list_of_slist xs" proof - have "list_of_pdevs (Pdevs xs) = map (λi. (i, pdevs_apply (Pdevs xs) i)) (rev (sorted_list_of_set (pdevs_domain (Pdevs xs))))" by (simp add: list_of_pdevs_def) also have "(sorted_list_of_set (pdevs_domain (Pdevs xs))) = rev (map fst (list_of_slist xs))" unfolding compute_pdevs_domain sorted_list_of_set_sort_remdups proof (transfer, goal_cases) case prems: (1 xs) hence distinct: "distinct (map fst [x←xs . snd x ≠ 0])" by (auto simp: filter_map distinct_map intro: subset_inj_on) with prems show ?case using sort_rev_eq_sort[symmetric, OF distinct] by (auto simp: rev_map rev_filter distinct_map distinct_remdups_id intro!: sorted_sort_id sorted_filter) qed also have "map (λi. (i, pdevs_apply (Pdevs xs) i)) (rev …) = list_of_slist xs" proof (transfer, goal_cases) case (1 xs) thus ?case unfolding Pdevs_raw_def o_def rev_rev_ident map_map by (subst map_cong[where g="λx. x"]) (auto simp: map_filter_map_filter) qed finally show ?thesis . qed lift_definition slist_of_pdevs::"'a pdevs ⇒ (nat, 'a::real_vector) slist" is list_of_pdevs by (auto simp: list_of_pdevs_def rev_map rev_filter filter_map o_def distinct_map image_def intro!: distinct_filter sorted_filter[of "λx. x", simplified]) subsection ‹Application› lift_definition slist_apply::"('a::linorder, 'b::zero) slist ⇒ 'a ⇒ 'b" is "λxs i. the_default 0 (map_of xs i)" . lemma compute_pdevs_apply[code]: "pdevs_apply (Pdevs x) i = slist_apply x i" by transfer (auto simp: Pdevs_raw_def) subsection ‹Total Deviation› lift_definition tdev_slist::"(nat, 'a::ordered_euclidean_space) slist ⇒ 'a" is "sum_list o map (abs o snd)" . lemma tdev_slist_sum: "tdev_slist xs = sum (abs ∘ snd) (set_slist xs)" by transfer (auto simp: distinct_map sum_list_distinct_conv_sum_set[symmetric] o_def) lemma pdevs_apply_set_slist: "x ∈ set_slist xs ⟹ snd x = pdevs_apply (Pdevs xs) (fst x)" by transfer (auto simp: Pdevs_raw_def) lemma tdev_list_eq_zeroI: shows "(⋀i. pdevs_apply (Pdevs xs) i = 0) ⟹ tdev_slist xs = 0" unfolding tdev_slist_sum by (auto simp: pdevs_apply_set_slist) lemma inj_on_fst_set_slist: "inj_on fst (set_slist xs)" by transfer (simp add: distinct_map) lemma pdevs_apply_Pdevs_eq_0: "pdevs_apply (Pdevs xs) i = 0 ⟷ ((∀x. (i, x) ∈ set_slist xs ⟶ x = 0))" by transfer (safe, auto simp: Pdevs_raw_def split: option.split) lemma compute_tdev[code]: "tdev (Pdevs xs) = tdev_slist xs" proof - have "tdev (Pdevs xs) = (∑i<degree (Pdevs xs). ¦pdevs_apply (Pdevs xs) i¦)" by (simp add: tdev_def) also have "… = (∑i <degree (Pdevs xs). if pdevs_apply (Pdevs xs) i = 0 then 0 else ¦pdevs_apply (Pdevs xs) i¦)" by (auto intro!: sum.cong) also have "… = (∑i∈{0..<degree (Pdevs xs)} ∩ {x. pdevs_apply (Pdevs xs) x ≠ 0}. ¦pdevs_apply (Pdevs xs) i¦)" by (auto simp: sum.If_cases Collect_neg_eq atLeast0LessThan) also have "… = (∑x∈fst ` set_slist xs. ¦pdevs_apply (Pdevs xs) x¦)" by (rule sum.mono_neutral_cong_left) (force simp: pdevs_apply_Pdevs_eq_0 intro!: imageI degree_gt)+ also have "… = (∑x∈set_slist xs. ¦pdevs_apply (Pdevs xs) (fst x)¦)" by (rule sum.reindex_cong[of fst]) (auto simp: inj_on_fst_set_slist) also have "… = tdev_slist xs" by (simp add: tdev_slist_sum pdevs_apply_set_slist) finally show ?thesis . qed subsection ‹Minkowski Sum› lemma dropWhile_rsorted_eq_filter: "rsorted (map fst xs) ⟹ dropWhile (λ(i, x). i ≥ (m::nat)) xs = filter (λ(i, x). i < m) xs" (is "_ ⟹ ?lhs xs = ?rhs xs") proof (induct xs) case (Cons x xs) hence "?rhs (x#xs) = ?lhs (x#xs)" by (auto simp: sorted_append filter_id_conv intro: sym) thus ?case .. qed simp lift_definition msum_slist::"nat ⇒ (nat, 'a) slist ⇒ (nat, 'a) slist ⇒ (nat, 'a) slist" is "λm xs ys. map (apfst (λn. n + m)) ys @ dropWhile (λ(i, x). i ≥ m) xs" proof (safe, goal_cases) case (1 n l1 l2) then have "set (dropWhile (λ(i, x). n ≤ i) l1) ⊆ set l1" by (simp add: set_dropWhileD subrelI) with 1 show ?case by (auto simp add: distinct_map add.commute [of _ n] intro!: comp_inj_on intro: subset_inj_on) (simp add: dropWhile_rsorted_eq_filter) next case prems: (2 n l1 l2) hence "sorted (map ((λna. na + n) ∘ fst) (rev l2))" by(simp add: sorted_iff_nth_mono rev_map) with prems show ?case by (auto simp: sorted_append dropWhile_rsorted_eq_filter rev_map rev_filter sorted_filter) qed lemma slist_apply_msum_slist: "slist_apply (msum_slist m xs ys) i = (if i < m then slist_apply xs i else slist_apply ys (i - m))" proof (transfer, goal_cases) case prems: (1 m xs ys i) thus ?case proof (cases "i ∈ dom (map_of (map (λ(x, y). (x + m, y)) ys))") case False have "⋀a. i < m ⟹ i ∉ fst ` {x ∈ set xs. case x of (i, x) ⇒ i < m} ⟹ (i, a) ∉ set xs" "⋀a. i ∉ fst ` set xs ⟹ (i, a) ∉ set xs" "⋀a. m ≤ i ⟹ i ∉ fst ` (λ(x, y). (x + m, y)) ` set ys ⟹ (i - m, a) ∉ set ys" by force+ thus ?thesis using prems False by (auto simp add: dropWhile_rsorted_eq_filter map_of_eq_None_iff distinct_map_fst_snd_eqD split: option.split dest!: map_of_SomeD) qed (force simp: map_of_eq_None_iff distinct_map_fst_snd_eqD split: option.split dest!: map_of_SomeD) qed lemma pdevs_apply_msum_slist: "pdevs_apply (Pdevs (msum_slist m xs ys)) i = (if i < m then pdevs_apply (Pdevs xs) i else pdevs_apply (Pdevs ys) (i - m))" by (auto simp: compute_pdevs_apply slist_apply_msum_slist) lemma compute_msum_pdevs[code]: "msum_pdevs m (Pdevs xs) (Pdevs ys) = Pdevs (msum_slist m xs ys)" by (rule pdevs_eqI) (auto simp: pdevs_apply_msum_slist pdevs_apply_msum_pdevs) subsection ‹Unary Operations› lift_definition map_slist::"('a ⇒ 'b) ⇒ (nat, 'a) slist ⇒ (nat, 'b) slist" is "λf. map (apsnd f)" by simp lemma pdevs_apply_map_slist: "f 0 = 0 ⟹ pdevs_apply (Pdevs (map_slist f xs)) i = f (pdevs_apply (Pdevs xs) i)" by transfer (force simp: Pdevs_raw_def map_of_eq_None_iff distinct_map_fst_snd_eqD image_def split: option.split dest: distinct_map_fst_snd_eqD) lemma compute_scaleR_pdves[code]: "scaleR_pdevs r (Pdevs xs) = Pdevs (map_slist (λx. r *⇩R x) xs)" and compute_pdevs_scaleR[code]: "pdevs_scaleR (Pdevs rs) x = Pdevs (map_slist (λr. r *⇩R x) rs)" and compute_uminus_pdevs[code]: "uminus_pdevs (Pdevs xs) = Pdevs (map_slist (λx. - x) xs)" and compute_abs_pdevs[code]: "abs_pdevs (Pdevs xs) = Pdevs (map_slist abs xs)" and compute_pdevs_inner[code]: "pdevs_inner (Pdevs xs) b = Pdevs (map_slist (λx. x ∙ b) xs)" and compute_pdevs_inner2[code]: "pdevs_inner2 (Pdevs xs) b c = Pdevs (map_slist (λx. (x ∙ b, x ∙ c)) xs)" and compute_inner_scaleR_pdevs[code]: "inner_scaleR_pdevs x (Pdevs ys) = Pdevs (map_slist (λy. (x ∙ y) *⇩R y) ys)" and compute_trunc_pdevs[code]: "trunc_pdevs p (Pdevs xs) = Pdevs (map_slist (λx. eucl_truncate_down p x) xs)" and compute_trunc_err_pdevs[code]: "trunc_err_pdevs p (Pdevs xs) = Pdevs (map_slist (λx. eucl_truncate_down p x - x) xs)" by (auto intro!: pdevs_eqI simp: pdevs_apply_map_slist zero_prod_def abs_pdevs_def) subsection ‹Filter› lift_definition filter_slist::"(nat ⇒ 'a ⇒ bool) ⇒ (nat, 'a) slist ⇒ (nat, 'a) slist" is "λP xs. filter (λ(i, x). (P i x)) xs" by (auto simp: o_def filter_map distinct_map rev_map rev_filter sorted_filter intro: subset_inj_on) lemma slist_apply_filter_slist: "slist_apply (filter_slist P xs) i = (if P i (slist_apply xs i) then slist_apply xs i else 0)" by transfer (force simp: Pdevs_raw_def o_def map_of_eq_None_iff distinct_map_fst_snd_eqD dest: map_of_SomeD distinct_map_fst_snd_eqD split: option.split) lemma pdevs_apply_filter_slist: "pdevs_apply (Pdevs (filter_slist P xs)) i = (if P i (pdevs_apply (Pdevs xs) i) then pdevs_apply (Pdevs xs) i else 0)" by (simp add: compute_pdevs_apply slist_apply_filter_slist) lemma compute_filter_pdevs[code]: "filter_pdevs P (Pdevs xs) = Pdevs (filter_slist P xs)" by (auto simp: pdevs_apply_filter_slist intro!: pdevs_eqI) subsection ‹Constant› lift_definition zero_slist::"(nat, 'a) slist" is "[]" by simp lemma compute_zero_pdevs[code]: "zero_pdevs = Pdevs (zero_slist)" by transfer (auto simp: Pdevs_raw_def) lift_definition One_slist::"(nat, 'a::executable_euclidean_space) slist" is "rev (zip [0..<length (Basis_list::'a list)] (Basis_list::'a list))" by (simp add: zip_rev[symmetric]) lemma map_of_rev_zip_upto_length_eq_nth: assumes "i < length B" "d = length B" shows "(map_of (rev (zip [0..<d] B)) i) = Some (B ! i)" proof - have "length (rev [0..<length B]) = length (rev B)" by simp from map_of_zip_is_Some[OF this, of i] assms obtain y where y: "map_of (zip (rev [0..<length B]) (rev B)) i = Some y" by (auto simp: zip_rev) hence "y = B ! i" by (auto simp: in_set_zip rev_nth) with y show ?thesis by (simp add: zip_rev assms) qed lemma map_of_rev_zip_upto_length_eq_None: assumes "¬i < length B" assumes "d = length B" shows "(map_of (rev (zip [0..<d] B)) i) = None" using assms by (auto simp: map_of_eq_None_iff in_set_zip) lemma pdevs_apply_One_slist: "pdevs_apply (Pdevs One_slist) i = (if i < length (Basis_list::'a::executable_euclidean_space list) then (Basis_list::'a list) ! i else 0)" by transfer (auto simp: Pdevs_raw_def map_of_rev_zip_upto_length_eq_nth map_of_rev_zip_upto_length_eq_None in_set_zip split: option.split) lemma compute_One_pdevs[code]: "One_pdevs = Pdevs One_slist" by (rule pdevs_eqI) (simp add: pdevs_apply_One_slist) lift_definition coord_slist::"nat ⇒ (nat, real) slist" is "λi. [(i, 1)]" by simp lemma compute_coord_pdevs[code]: "coord_pdevs i = Pdevs (coord_slist i)" by transfer (auto simp: Pdevs_raw_def) subsection ‹Update› primrec update_list::"nat ⇒ 'a ⇒ (nat * 'a) list ⇒ (nat * 'a) list" where "update_list n x [] = [(n, x)]" | "update_list n x (y#ys) = (if n > fst y then (n, x)#y#ys else if n = fst y then (n, x)#ys else y#(update_list n x ys))" lemma map_of_update_list[simp]: "map_of (update_list n x ys) = (map_of ys)(n:=Some x)" by (induct ys) auto lemma in_set_update_listD: assumes "y ∈ set (update_list n x ys)" shows "y = (n, x) ∨ (y ∈ set ys)" using assms by (induct ys) (auto split: if_split_asm) lemma in_set_update_listI: "y = (n, x) ∨ (fst y ≠ n ∧ y ∈ set ys) ⟹ y ∈ set (update_list n x ys)" by (induct ys) (auto split: if_split_asm) lemma in_set_update_list: "(n, x) ∈ set (update_list n x xs)" by (induct xs) simp_all lemma overwrite_update_list: "(a, b) ∈ set xs ⟹ (a, b) ∉ set (update_list n x xs) ⟹ a = n" by (induct xs) (auto split: if_split_asm) lemma insert_update_list: "distinct (map fst xs) ⟹ rsorted (map fst xs) ⟹ (a, b) ∈ set (update_list a x xs) ⟹ b = x" by (induct xs) (force split: if_split_asm simp: sorted_append)+ lemma set_update_list_eq: "distinct (map fst xs) ⟹ rsorted (map fst xs) ⟹ set (update_list n x xs) = insert (n, x) (set xs - {x. fst x = n})" by (auto intro!: in_set_update_listI dest: in_set_update_listD simp: insert_update_list) lift_definition update_slist::"nat ⇒ 'a ⇒ (nat, 'a) slist ⇒ (nat, 'a) slist" is update_list proof goal_cases case (1 n a l) thus ?case by (induct l) (force simp: sorted_append distinct_map not_less dest!: in_set_update_listD)+ qed lemma pdevs_apply_update_slist: "pdevs_apply (Pdevs (update_slist n x xs)) i = (if i = n then x else pdevs_apply (Pdevs xs) i)" by transfer (auto simp: Pdevs_raw_def) lemma compute_pdev_upd[code]: "pdev_upd (Pdevs xs) n x = Pdevs (update_slist n x xs)" by (rule pdevs_eqI) (auto simp: pdevs_apply_update_slist) subsection ‹Approximate Total Deviation› lift_definition fold_slist::"('a ⇒ 'b ⇒ 'b) ⇒ (nat, 'a::zero) slist ⇒ 'b ⇒ 'b" is "λf xs z. fold (f o snd) (filter (λx. snd x ≠ 0) xs) z" . lemma Pdevs_raw_Cons: "Pdevs_raw ((a, b) # xs) = (λi. if i = a then b else Pdevs_raw xs i)" by (auto simp: Pdevs_raw_def map_of_eq_None_iff dest!: map_of_SomeD split: option.split) lemma zeros_aux: "- (λi. if i = a then b else Pdevs_raw xs i) -` {0} ⊆ - Pdevs_raw xs -` {0} ∪ {a}" by auto lemma compute_tdev'[code]: "tdev' p (Pdevs xs) = fold_slist (λa b. eucl_truncate_up p (¦a¦ + b)) xs 0" unfolding tdev'_def sum_list'_def compute_list_of_pdevs by transfer (auto simp: o_def fold_map) subsection ‹Equality› lemma slist_apply_list_of_slist_eq: "slist_apply a i = the_default 0 (map_of (list_of_slist a) i)" by (transfer) (force split: option.split simp: map_of_eq_None_iff distinct_map_fst_snd_eqD dest!: map_of_SomeD) lemma compute_equal_pdevs[code]: "equal_class.equal (Pdevs a) (Pdevs b) ⟷ (list_of_slist a) = (list_of_slist b)" by (auto intro!: pdevs_eqI simp: equal_pdevs_def compute_pdevs_apply slist_apply_list_of_slist_eq compute_list_of_pdevs[symmetric]) subsection ‹From List of Generators› lift_definition slist_of_list::"'a::zero list ⇒ (nat, 'a) slist" is "λxs. rev (zip [0..<length xs] xs)" by (auto simp: rev_map[symmetric] ) lemma slist_apply_slist_of_list: "slist_apply (slist_of_list xs) i = (if i < length xs then xs ! i else 0)" by transfer (auto simp: in_set_zip map_of_rev_zip_upto_length_eq_nth map_of_rev_zip_upto_length_eq_None) lemma compute_pdevs_of_list[code]: "pdevs_of_list xs = Pdevs (slist_of_list xs)" by (rule pdevs_eqI) (auto simp: compute_pdevs_apply slist_apply_slist_of_list pdevs_apply_pdevs_of_list) text ‹abstraction function which can be used in code equations› lift_definition abs_slist_if::"('a::linorder×'b) list ⇒ ('a, 'b) slist" is "λlist. if distinct (map fst list) ∧ rsorted (map fst list) then list else []" by auto definition "slist = Abs_slist" lemma [code_post]: "Abs_slist = slist" by (simp add: slist_def) lemma [code]: "slist = (λxs. (if distinct (map fst xs) ∧ rsorted (map fst xs) then abs_slist_if xs else Code.abort (STR '''') (λ_. slist xs)))" by (auto simp add: slist_def abs_slist_if.abs_eq) abbreviation "pdevs ≡ (λx. Pdevs (slist x))" lift_definition nlex_slist::"(nat, point) slist ⇒ (nat, point) slist" is "map (λ(i, x). (i, if lex 0 x then - x else x))" by (auto simp: o_def split_beta') lemma Pdevs_raw_map: "f 0 = 0 ⟹ Pdevs_raw (map (λ(i, x). (i, f x)) xs) i = f (Pdevs_raw xs i)" by (auto simp: Pdevs_raw_def map_of_map split: option.split) lemma compute_nlex_pdevs[code]: "nlex_pdevs (Pdevs x) = Pdevs (nlex_slist x)" by transfer (auto simp: Pdevs_raw_map) end
section ‹Optimizations for Code Integer› theory Optimize_Integer imports Complex_Main "HOL-Library.Code_Target_Numeral" begin text ‹shallowly embed log and power› definition log2::"int ⇒ int" where "log2 a = floor (log 2 (of_int a))" context includes integer.lifting begin lift_definition log2_integer :: "integer ⇒ integer" is "log2 :: int ⇒ int" . end lemma [code]: "log2 (int_of_integer a) = int_of_integer (log2_integer a)" by (simp add: log2_integer.rep_eq) code_printing constant "log2_integer :: integer ⇒ _" ⇀ (SML) "IntInf.log2" definition power_int::"int ⇒ int ⇒ int" where "power_int a b = a ^ (nat b)" context includes integer.lifting begin lift_definition power_integer :: "integer ⇒ integer ⇒ integer" is "power_int :: int ⇒ int ⇒ int" . end code_printing constant "power_integer :: integer ⇒ _ ⇒ _" ⇀ (SML) "IntInf.pow ((_), (_))" lemma [code]: "power_int (int_of_integer a) (int_of_integer b) = int_of_integer (power_integer a b)" by (simp add: power_integer.rep_eq) end
section ‹Optimizations for Code Float› theory Optimize_Float imports "HOL-Library.Float" Optimize_Integer begin lemma compute_bitlen[code]: "bitlen a = (if a > 0 then log2 a + 1 else 0)" by (simp add: bitlen_alt_def log2_def) lemma compute_float_plus[code]: "Float m1 e1 + Float m2 e2 = (if m1 = 0 then Float m2 e2 else if m2 = 0 then Float m1 e1 else if e1 ≤ e2 then Float (m1 + m2 * power_int 2 (e2 - e1)) e1 else Float (m2 + m1 * power_int 2 (e1 - e2)) e2)" by (simp add: Float.compute_float_plus power_int_def) lemma compute_real_of_float[code]: "real_of_float (Float m e) = (if e ≥ 0 then m * 2 ^ nat e else m / power_int 2 (-e))" unfolding power_int_def[symmetric, of 2 e] using compute_real_of_float power_int_def by auto lemma compute_float_down[code]: "float_down p (Float m e) = (if p + e < 0 then Float (m div power_int 2 (-(p + e))) (-p) else Float m e)" by (simp add: Float.compute_float_down power_int_def) lemma compute_lapprox_posrat[code]: fixes prec::nat and x y::nat shows "lapprox_posrat prec x y = (let l = rat_precision prec x y; d = if 0 ≤ l then int x * power_int 2 l div y else int x div power_int 2 (- l) div y in normfloat (Float d (- l)))" by (auto simp add: Float.compute_lapprox_posrat power_int_def Let_def zdiv_int of_nat_power of_nat_mult) lemma compute_rapprox_posrat[code]: fixes prec x y defines "l ≡ rat_precision prec x y" shows "rapprox_posrat prec x y = (let l = l ; (r, s) = if 0 ≤ l then (int x * power_int 2 l, int y) else (int x, int y * power_int 2 (-l)) ; d = r div s ; m = r mod s in normfloat (Float (d + (if m = 0 ∨ y = 0 then 0 else 1)) (- l)))" by (auto simp add: l_def Float.compute_rapprox_posrat power_int_def Let_def zdiv_int of_nat_power of_nat_mult) lemma compute_float_truncate_down[code]: "float_round_down prec (Float m e) = (let d = bitlen (abs m) - int prec - 1 in if 0 < d then let P = power_int 2 d ; n = m div P in Float n (e + d) else Float m e)" by (simp add: Float.compute_float_round_down power_int_def cong: if_cong) lemma compute_int_floor_fl[code]: "int_floor_fl (Float m e) = (if 0 ≤ e then m * power_int 2 e else m div (power_int 2 (-e)))" by (simp add: Float.compute_int_floor_fl power_int_def) lemma compute_floor_fl[code]: "floor_fl (Float m e) = (if 0 ≤ e then Float m e else Float (m div (power_int 2 ((-e)))) 0)" by (simp add: Float.compute_floor_fl power_int_def) end
section ‹Target Language debug messages› theory Print imports "HOL-Decision_Procs.Approximation" Affine_Code Show.Show_Instances "HOL-Library.Monad_Syntax" Optimize_Float begin hide_const (open) floatarith.Max subsection ‹Printing› text ‹Just for debugging purposes› definition print::"String.literal ⇒ unit" where "print x = ()" context includes integer.lifting begin end code_printing constant print ⇀ (SML) "TextIO.print" subsection ‹Write to File› definition file_output::"String.literal ⇒ ((String.literal ⇒ unit) ⇒ 'a) ⇒ 'a" where "file_output _ f = f (λ_. ())" code_printing constant file_output ⇀ (SML) "(fn s => fn f => File.open'_output (fn os => f (File.output os)) (Path.explode s))" subsection ‹Show for Floats› definition showsp_float :: "float showsp" where "showsp_float p x = ( let m = mantissa x; e = exponent x in if e = 0 then showsp_int p m else showsp_int p m o shows_string ''*2^'' o showsp_int p e)" lemma show_law_float [show_law_intros]: "show_law showsp_float r" by (auto simp: showsp_float_def Let_def show_law_simps intro!: show_lawI) lemma showsp_float_append [show_law_simps]: "showsp_float p r (x @ y) = showsp_float p r x @ y" by (intro show_lawD show_law_intros) local_setup ‹Show_Generator.register_foreign_showsp @{typ float} @{term "showsp_float"} @{thm show_law_float}› derive "show" float subsection ‹Convert Float to Decimal number› text ‹type for decimal floating point numbers (currently just for printing, TODO? generalize theory Float for arbitrary base)› datatype float10 = Float10 (mantissa10: int) (exponent10: int) notation Float10 (infix "𝖾" 999) partial_function (tailrec) normalize_float10 where [code]: "normalize_float10 f = (if mantissa10 f mod 10 ≠ 0 ∨ mantissa10 f = 0 then f else normalize_float10 (Float10 (mantissa10 f div 20) (exponent10 f + 1)))" subsubsection ‹Version that should be easy to prove correct, but slow!› context includes floatarith_notation begin definition "float_to_float10_approximation f = the (do { let (x, y) = (mantissa f * 1024, exponent f - 10); let p = nat (bitlen (abs x) + bitlen (abs y) + 80); ― ‹FIXME: are there guarantees?› y_log ← approx p (Mult (Num (of_int y)) ((Mult (Ln (Num 2)) (Inverse (Ln (Num 10)))))) []; let e_fl = floor_fl (lower y_log); let e = int_floor_fl e_fl; m ← approx p (Mult (Num (of_int x)) (Powr (Num 10) (Add(Var 0) (Minus (Num e_fl))))) [Some y_log]; let ml = lower m; let mu = upper m; Some (normalize_float10 (Float10 (int_floor_fl ml) e), normalize_float10 (Float10 (- int_floor_fl (- mu)) e)) })" end lemma compute_float_of[code]: "float_of (real_of_float f) = f" by simp subsection ‹Trusted, but faster version› text ‹TODO: this is the HOL version of the SML-code in Approximation.thy› lemma prod_case_call_mono[partial_function_mono]: "mono_tailrec (λf. (let (d, e) = a in (λy. f (c d e y))) b)" by (simp add: split_beta' call_mono) definition divmod_int::"int ⇒ int ⇒ int * int" where "divmod_int a b = (a div b, a mod b)" partial_function (tailrec) f2f10_frac where "f2f10_frac c p r digits cnt e = (if r = 0 then (digits, cnt, 0) else if p = 0 then (digits, cnt, r) else (let (d, r) = divmod_int (r * 10) (power_int 2 (-e)) in f2f10_frac (c ∨ d ≠ 0) (if d ≠ 0 ∨ c then p - 1 else p) r (digits * 10 + d) (cnt + 1)) e)" declare f2f10_frac.simps[code] definition float2_float10::"int ⇒ bool ⇒ int ⇒ int ⇒ (int * int)" where "float2_float10 prec rd m e = ( let (m, e) = (if e < 0 then (m,e) else (m * power_int 2 e, 0)); sgn = sgn m; m = abs m; round_down = (sgn = 1 ∧ rd) ∨ (sgn = -1 ∧ ¬ rd); (x, r) = divmod_int m ((power_int 2 (-e))); p = ((if x = 0 then prec else prec - (log2 x + 1)) * 3) div 10 + 1; (digits, e10, r) = if p > 0 then f2f10_frac (x ≠ 0) p r 0 0 e else (0,0,0); digits = if round_down ∨ r = 0 then digits else digits + 1 in (sgn * (digits + x * (power_int 10 e10)), -e10))" definition "lfloat10 r = (let f = float_of r in case_prod Float10 (float2_float10 20 True (mantissa f) (exponent f)))" definition "ufloat10 r = (let f = float_of r in case_prod Float10 (float2_float10 20 False (mantissa f) (exponent f)))" partial_function (tailrec) digits where [code]: "digits m ds = (if m = 0 then ds else digits (m div 10) (m mod 10 # ds))" primrec showsp_float10 :: "float10 showsp" where "showsp_float10 p (Float10 m e) = ( let ds = digits (nat (abs m)) []; d = int (length ds); e = e + d - 1; mp = take 1 ds; ms = drop 1 ds; ms = rev (dropWhile ((=) 0) (rev ms)); show_digits = shows_list_gen (showsp_nat p) ''0'' '''' '''' '''' in (if m < 0 then shows_string ''-'' else (λx. x)) o show_digits mp o (if ms = [] then (λx. x) else shows_string ''.'' o show_digits ms) o (if e = 0 then (λx. x) else shows_string ''e'' o showsp_int p e))" lemma show_law_float10_aux: fixes m e shows "show_law showsp_float10 (Float10 m e)" apply (rule show_lawI) unfolding showsp_float10.simps Let_def apply (simp add: show_law_simps ) done lemma show_law_float10 [show_law_intros]: "show_law showsp_float10 r" by (cases r) (auto simp: show_law_float10_aux) lemma showsp_float10_append [show_law_simps]: "showsp_float10 p r (x @ y) = showsp_float10 p r x @ y" by (intro show_lawD show_law_intros) local_setup ‹Show_Generator.register_foreign_showsp @{typ float10} @{term "showsp_float10"} @{thm show_law_float10}› derive "show" float10 definition "showsp_real p x = showsp_float10 p (lfloat10 x)" lemma show_law_real[show_law_intros]: "show_law showsp_real x" using show_law_float10[of "lfloat10 x"] by (auto simp: showsp_real_def[abs_def] Let_def show_law_def simp del: showsp_float10.simps intro!: show_law_intros) local_setup ‹Show_Generator.register_foreign_showsp @{typ real} @{term "showsp_real"} @{thm show_law_real}› derive "show" real subsection ‹gnuplot output› subsubsection ‹vector output of 2D zonotope› fun polychain_of_segments::"((real × real) × (real × real)) list ⇒ (real × real) list" where "polychain_of_segments [] = []" | "polychain_of_segments (((x0, y0), z)#segs) = (x0, y0)#z#map snd segs" definition shows_segments_of_aform where "shows_segments_of_aform a b xs color = shows_list_gen id '''' '''' ''⏎'' ''⏎'' (map (λ(x0, y0). shows_words (map lfloat10 [x0, y0]) o shows_space o shows_string color) (polychain_of_segments (segments_of_aform (prod_of_aforms (xs ! a) (xs ! b)))))" abbreviation "show_segments_of_aform a b x c ≡ shows_segments_of_aform a b x c ''''" definition shows_box_of_aforms― ‹box and some further information› where "shows_box_of_aforms (XS::real aform list) = (let RS = map (Radius' 20) XS; l = map (Inf_aform' 20) XS; u = map (Sup_aform' 20) XS in shows_words (l @ u @ RS) o shows_space o shows (card (⋃((λx. pdevs_domain (snd x)) ` (set XS)))) )" abbreviation "show_box_of_aforms x ≡ shows_box_of_aforms x ''''" definition "pdevs_domains ((XS::real aform list)) = (⋃((λx. pdevs_domain (snd x)) ` (set XS)))" definition "generators XS = (let is = sorted_list_of_set (pdevs_domains XS); rs = map (λi. (i, map (λx. pdevs_apply (snd x) i) XS)) is in (map fst XS, rs))" definition shows_box_of_aforms_hr― ‹human readable› where "shows_box_of_aforms_hr XS = (let RS = map (Radius' 20) XS; l = map (Inf_aform' 20) XS; u = map (Sup_aform' 20) XS in shows_paren (shows_words l) o shows_string '' .. '' o shows_paren (shows_words u) o shows_string ''; devs: '' o shows (card (pdevs_domains XS)) o shows_string ''; tdev: '' o shows_paren (shows_words RS) )" abbreviation "show_box_of_aforms_hr x ≡ shows_box_of_aforms_hr x ''''" definition shows_aforms_hr― ‹human readable› where "shows_aforms_hr XS = shows (generators XS)" abbreviation "show_aform_hr x ≡ shows_aforms_hr x ''''" end
section ‹Dyadic Rational Representation of Real› theory Float_Real imports "HOL-Library.Float" Optimize_Float begin text ‹\label{sec:floatreal}› code_datatype real_of_float abbreviation float_of_nat :: "nat ⇒ float" where "float_of_nat ≡ of_nat" abbreviation float_of_int :: "int ⇒ float" where "float_of_int ≡ of_int" text‹Collapse nested embeddings› text ‹Operations› text ‹Undo code setup for @{term Ratreal}.› lemma of_rat_numeral_eq [code_abbrev]: "real_of_float (numeral w) = Ratreal (numeral w)" by simp lemma zero_real_code [code]: "0 = real_of_float 0" by simp lemma one_real_code [code]: "1 = real_of_float 1" by simp lemma [code_abbrev]: "(real_of_float (of_int a) :: real) = (Ratreal (Rat.of_int a) :: real)" by (auto simp: Rat.of_int_def ) lemma [code_abbrev]: "real_of_float 0 ≡ Ratreal 0" by simp lemma [code_abbrev]: "real_of_float 1 = Ratreal 1" by simp lemmas compute_real_of_float[code del] lemmas [code del] = real_equal_code real_less_eq_code real_less_code real_plus_code real_times_code real_uminus_code real_minus_code real_inverse_code real_divide_code real_floor_code Float.compute_truncate_down Float.compute_truncate_up lemma real_equal_code [code]: "HOL.equal (real_of_float x) (real_of_float y) ⟷ HOL.equal x y" by (metis (poly_guards_query) equal real_of_float_inverse) abbreviation FloatR::"int⇒int⇒real" where "FloatR a b ≡ real_of_float (Float a b)" lemma real_less_eq_code' [code]: "real_of_float x ≤ real_of_float y ⟷ x ≤ y" and real_less_code' [code]: "real_of_float x < real_of_float y ⟷ x < y" and real_plus_code' [code]: "real_of_float x + real_of_float y = real_of_float (x + y)" and real_times_code' [code]: "real_of_float x * real_of_float y = real_of_float (x * y)" and real_uminus_code' [code]: "- real_of_float x = real_of_float (- x)" and real_minus_code' [code]: "real_of_float x - real_of_float y = real_of_float (x - y)" and real_inverse_code' [code]: "inverse (FloatR a b) = (if FloatR a b = 2 then FloatR 1 (-1) else if a = 1 then FloatR 1 (- b) else Code.abort (STR ''inverse not of 2'') (λ_. inverse (FloatR a b)))" and real_divide_code' [code]: "FloatR a b / FloatR c d = (if FloatR c d = 2 then if a mod 2 = 0 then FloatR (a div 2) b else FloatR a (b - 1) else if c = 1 then FloatR a (b - d) else Code.abort (STR ''division not by 2'') (λ_. FloatR a b / FloatR c d))" and real_floor_code' [code]: "floor (real_of_float x) = int_floor_fl x" and real_abs_code' [code]: "abs (real_of_float x) = real_of_float (abs x)" by (auto simp add: int_floor_fl.rep_eq powr_diff powr_minus inverse_eq_divide) lemma compute_round_down[code]: "round_down prec (real_of_float f) = real_of_float (float_down prec f)" by simp lemma compute_round_up[code]: "round_up prec (real_of_float f) = real_of_float (float_up prec f)" by simp lemma compute_truncate_down[code]: "truncate_down prec (real_of_float f) = real_of_float (float_round_down prec f)" by (simp add: Float.float_round_down.rep_eq truncate_down_def) lemma compute_truncate_up[code]: "truncate_up prec (real_of_float f) = real_of_float (float_round_up prec f)" by (simp add: float_round_up.rep_eq truncate_up_def) lemma [code]: "real_divl p (real_of_float x) (real_of_float y) = real_of_float (float_divl p x y)" by (simp add: float_divl.rep_eq real_divl_def) lemma [code]: "real_divr p (real_of_float x) (real_of_float y) = real_of_float (float_divr p x y)" by (simp add: float_divr.rep_eq real_divr_def) lemmas [code] = real_of_float_inverse end
section ‹Examples› theory Ex_Affine_Approximation imports Affine_Code Print Float_Real begin context includes floatarith_notation begin definition "rotate_fas = [Cos (Rad_of (Var 2)) * Var 0 - Sin (Rad_of (Var 2)) * Var 1, Sin (Rad_of (Var 2)) * Var 0 + Cos (Rad_of (Var 2)) * Var 1]" definition "rotate_slp = slp_of_fas rotate_fas" definition "approx_rotate p t X = approx_slp_outer p 3 rotate_slp X" fun rotate_aform where "rotate_aform x i = (let r = (((the o (λx. approx_rotate 30 (FloatR 1 (-3)) x))^^i) x) in (r ! 0) ×⇩a (r ! 1) ×⇩a (r ! 2))" value [code] "rotate_aform (aforms_of_ivls [2, 1, 45] [3, 5, 45]) 70" definition "translate_slp = slp_of_fas [Var 0 + Var 2, Var 1 + Var 2]" fun translatei where "translatei x i = (((the o (λx. approx_slp_outer 7 3 translate_slp x))^^i) x)" value "translatei (aforms_of_ivls [2, 1, 512] [3, 5, 512]) 50" end hide_const rotate_fas rotate_slp approx_rotate rotate_aform translate_slp translatei end
section‹Examples on Proving Inequalities› theory Ex_Ineqs imports Affine_Code Print Float_Real begin definition "plotcolors = [[(0, 1, ''0x000000'')], [(0, 2, ''0xff0000''), (1, 2, ''0x7f0000'')], [(0, 3, ''0x00ff00''), (1, 3, ''0x00aa00''), (2, 3, ''0x005500'')], [(1, 4, ''0x0000ff''), (2, 4, ''0x0000c0''), (3, 4, ''0x00007f''), (0, 4, ''0x00003f'')], [(0, 5, ''0x00ffff''), (1, 5, ''0x00cccc''), (2, 5, ''0x009999''), (3, 5, ''0x006666''), (4, 5, ''0x003333'')], [(0, 6, ''0xff00ff''), (1, 6, ''0xd500d5''), (2, 6, ''0xaa00aa''), (3, 6, ''0x800080''), (4, 6, ''0x550055''), (5, 6, ''0x2a002a'')]]" primrec prove_pos::"(nat * nat * string) list ⇒ nat ⇒ nat ⇒ (nat ⇒ real aform list ⇒ real aform option) ⇒ real aform list list ⇒ bool" where "prove_pos prnt 0 p F X = (let _ = if prnt ≠ [] then print (STR ''# depth limit exceeded⏎'') else () in False)" | "prove_pos prnt (Suc i) p F XXS = (case XXS of [] ⇒ True | (X#XS) ⇒ let R = F p X; _ = if prnt ≠ [] then print (String.implode ((shows ''# '' o shows_box_of_aforms_hr X) ''⏎'')) else (); _ = fold (λ(a, b, c) _. print (String.implode (shows_segments_of_aform a b X c ''⏎''))) prnt () in if R ≠ None ∧ 0 < Inf_aform' p (the R) then let _ = if prnt ≠ [] then print (STR ''# Success⏎'') else () in prove_pos prnt i p F XS else let _ = if prnt ≠ [] then print (STR ''# Split⏎'') else () in case split_aforms_largest_uncond X of (a, b) ⇒ prove_pos prnt i p F (a#b#XS))" definition "prove_pos_slp prnt p fa i xs = (let slp = slp_of_fas [fa] in prove_pos prnt i p (λp xs. case approx_slp_outer p 1 slp xs of None ⇒ None | Some [x] ⇒ Some x | Some _ ⇒ None) xs)" text‹\label{sec:examples}› experiment begin unbundle floatarith_notation text ‹The examples below are taken from @{url "http://link.springer.com/chapter/10.1007/978-3-642-38088-4_26"}, ``Formal Verification of Nonlinear Inequalities with Taylor Interval Approximations'', Alexey Solovyev, Thomas C. Hales, NASA Formal Methods 2013, LNCS 7871 › definition "schwefel = (5.8806 / 10 ^ 10) + (Var 0 - (Var 1)^⇩e2)^⇩e2 + (Var 1 - 1)^⇩e2 + (Var 0 - (Var 2)^⇩e2)^⇩e2 + (Var 2 - 1)^⇩e2" lemma schwefel: "5.8806 / 10 ^ 10 + (x0 - (x1)⇧2)⇧2 + (x1 - 1)⇧2 + (x0 - (x2)⇧2)⇧2 + (x2 - 1)⇧2 = interpret_floatarith schwefel [x0, x1, x2]" by (simp add: schwefel_def) lemma "prove_pos_slp [] 30 schwefel 100000 [aforms_of_ivls [-10,-10,-10] [10,10,10]]" unfolding schwefel_def by eval definition "delta6 = (Var 0 * Var 3 * (-Var 0 + Var 1 + Var 2 - Var 3 + Var 4 + Var 5) + Var 1 * Var 4 * ( Var 0 - Var 1 + Var 2 + Var 3 - Var 4 + Var 5) + Var 2 * Var 5 * ( Var 0 + Var 1 - Var 2 + Var 3 + Var 4 - Var 5) - Var 1 * Var 2 * Var 3 - Var 0 * Var 2 * Var 4 - Var 0 * Var 1 * Var 5 - Var 3 * Var 4 * Var 5)" schematic_goal delta6: "(x0 * x3 * (-x0 + x1 + x2 - x3 + x4 + x5) + x1 * x4 * ( x0 - x1 + x2 + x3 - x4 + x5) + x2 * x5 * ( x0 + x1 - x2 + x3 + x4 - x5) - x1 * x2 * x3 - x0 * x2 * x4 - x0 * x1 * x5 - x3 * x4 * x5) = interpret_floatarith delta6 [x0, x1, x2, x3, x4, x5]" by (simp add: delta6_def) lemma "prove_pos_slp [] 20 delta6 10000 [aforms_of_ivls (replicate 6 4) (replicate 6 (FloatR 104045 (-14)))]" unfolding delta6_def by eval definition "caprasse = (3.1801 + - Var 0 * (Var 2) ^⇩e 3 + 4 * Var 1 * (Var 2)^⇩e2 * Var 3 + 4 * Var 0 * Var 2 * (Var 3)^⇩e2 + 2 * Var 1 * (Var 3)^⇩e3 + 4 * Var 0 * Var 2 + 4 * (Var 2)^⇩e2 - 10 * Var 1 * Var 3 + -10 * (Var 3)^⇩e2 + 2)" schematic_goal caprasse: "(3.1801 + - xs!0 * (xs!2) ^ 3 + 4 * xs!1 * (xs!2)⇧2 * xs!3 + 4 * xs!0 * xs!2 * (xs!3)⇧2 + 2 * xs!1 * (xs!3)^3 + 4 * xs!0 * xs!2 + 4 * (xs!2)⇧2 - 10 * xs!1 * xs!3 + -10 * (xs!3)⇧2 + 2) = interpret_floatarith caprasse xs" by (simp add: caprasse_def) lemma "prove_pos_slp [] 20 caprasse 10000 [aforms_of_ivls (replicate 4 (1/2)) (replicate 4 (1/2))]" unfolding caprasse_def by eval definition "magnetism = 0.25001 + (Var 0)^⇩e2 + 2 * (Var 1)^⇩e2 + 2 * (Var 2)^⇩e2 + 2 * (Var 3)^⇩e2 + 2 * (Var 4)^⇩e2 + 2 * (Var 5)^⇩e2 + 2 * (Var 6)^⇩e2 - Var 0" schematic_goal magnetism: "0.25001 + (xs!0)⇧2 + 2 * (xs!1)⇧2 + 2 * (xs!2)⇧2 + 2 * (xs!3)⇧2 + 2 * (xs!4)⇧2 + 2 * (xs!5)⇧2 + 2 * (xs!6)⇧2 - xs!0 = interpret_floatarith magnetism xs" by (simp add: magnetism_def) end end
section ‹Examples: Intersection of Zonotopes with Hyperplanes› theory Ex_Inter imports Intersection Affine_Code Print begin subsection ‹Example› definition zono1::"(real*real*real) aform" where "zono1 = msum_aform 53 (aform_of_ivl ((0,0,0)::real*real*real) ((1,2,0)::real*real*real)) (0, pdevs_of_list [(5, 10, 20)])" definition interzono1::"(real*real*real) aform" where "interzono1 = the (inter_aform_plane_ortho 53 zono1 (0, 0, 1) 3)" text ‹10-dimensional zonotope with 50 generators› definition random_zono::"(real*real*real*real*real*real*real*real*real*real) aform" where "random_zono = (0, pdevs_of_list [(5, 9, 27, 12, 23, 3, 9, 10, 18, 2), (26, 4, 14, 15, 11, 7, 27, 5, 21, 16), (10, 17, 11, 27, 13, 14, 27, 14, 25, 23), (7, 6, 5, 30, 14, 10, 2, 1, 18, 25), (17, 5, 28, 6, 10, 22, 5, 18, 8, 11), (5, 7, 14, 14, 5, 11, 5, 17, 1, 22), (3, 6, 11, 20, 28, 13, 12, 10, 2, 23), (3, 1, 26, 15, 1, 3, 25, 23, 6, 18), (30, 8, 24, 16, 8, 20, 27, 25, 21, 17), (30, 4, 8, 12, 8, 4, 22, 27, 23, 2), (24, 21, 19, 15, 24, 22, 16, 15, 25, 6), (20, 4, 1, 24, 2, 9, 19, 4, 21, 17), (1, 12, 13, 7, 8, 8, 2, 11, 28, 6), (26, 25, 19, 8, 6, 26, 27, 17, 27, 25), (8, 8, 1, 4, 6, 2, 28, 13, 18, 28), (14, 14, 12, 7, 26, 19, 9, 25, 21, 17), (25, 14, 30, 17, 24, 17, 7, 25, 25, 5), (27, 21, 29, 22, 30, 10, 13, 15, 23, 19), (27, 5, 10, 4, 11, 12, 3, 20, 8, 23), (29, 11, 19, 12, 2, 28, 30, 27, 27, 1), (18, 7, 23, 1, 14, 6, 23, 22, 23, 19), (7, 17, 3, 15, 28, 15, 9, 16, 23, 7), (18, 25, 10, 13, 17, 14, 3, 24, 14, 7), (28, 13, 6, 27, 8, 14, 7, 14, 5, 24), (17, 5, 18, 9, 2, 11, 24, 17, 3, 2), (13, 17, 15, 30, 27, 29, 29, 16, 27, 13), (25, 21, 21, 17, 19, 3, 26, 27, 26, 2), (5, 16, 21, 18, 23, 1, 19, 13, 10, 2), (8, 27, 14, 16, 2, 11, 27, 27, 29, 2), (10, 22, 1, 23, 2, 22, 17, 22, 19, 15), (16, 8, 9, 27, 19, 23, 24, 30, 1, 3), (2, 20, 9, 12, 19, 21, 30, 9, 19, 13), (23, 21, 28, 26, 27, 17, 22, 9, 17, 13), (24, 1, 19, 19, 28, 21, 4, 8, 10, 20), (27, 19, 7, 23, 11, 30, 12, 10, 27, 20), (4, 3, 23, 21, 17, 13, 25, 8, 13, 26), (11, 25, 7, 2, 27, 10, 15, 14, 17, 23), (25, 27, 28, 15, 11, 4, 30, 25, 16, 1), (27, 26, 11, 21, 9, 14, 15, 11, 30, 18), (3, 19, 13, 17, 13, 9, 22, 4, 20, 30), (21, 26, 20, 8, 19, 1, 22, 9, 28, 15), (22, 12, 5, 25, 29, 27, 13, 9, 2, 10), (9, 24, 30, 6, 23, 13, 18, 15, 30, 20), (13, 5, 7, 6, 21, 30, 7, 22, 26, 15), (9, 3, 3, 1, 29, 16, 10, 2, 21, 25), (3, 14, 22, 18, 21, 15, 16, 22, 27, 26), (16, 25, 16, 22, 27, 18, 4, 15, 9, 21), (30, 23, 29, 24, 20, 14, 15, 25, 3, 22), (6, 18, 17, 14, 19, 25, 9, 22, 7, 26), (24, 7, 30, 27, 9, 2, 8, 23, 24, 1)])" text ‹10-dimensional zonotope with 100 generators› definition random_zono2::"(real*real*real*real*real*real*real*real*real*real) aform" where "random_zono2 = (0, pdevs_of_list [(17, 28, 12, 10, 18, 3, 14, 27, 21, 22), (7, 17, 16, 26, 25, 4, 12, 20, 18, 28), (11, 8, 30, 20, 11, 17, 8, 13, 28, 18), (18, 20, 26, 12, 25, 24, 23, 24, 22, 2), (14, 27, 20, 12, 16, 7, 21, 5, 5, 20), (4, 27, 8, 19, 11, 14, 9, 25, 8, 11), (14, 29, 12, 28, 29, 21, 20, 6, 18, 6), (20, 25, 8, 19, 30, 1, 21, 18, 7, 18), (5, 6, 7, 25, 30, 2, 19, 7, 13, 19), (11, 15, 16, 13, 17, 2, 9, 10, 29, 17), (29, 1, 30, 6, 6, 27, 19, 24, 11, 12), (27, 30, 8, 11, 30, 2, 19, 25, 5, 27), (3, 26, 16, 18, 12, 11, 4, 8, 2, 4), (16, 7, 11, 23, 29, 30, 22, 22, 5, 21), (6, 12, 28, 24, 12, 4, 11, 27, 6, 13), (30, 13, 16, 29, 22, 7, 10, 12, 3, 17), (26, 22, 6, 4, 8, 11, 29, 23, 13, 17), (30, 23, 20, 3, 4, 28, 25, 26, 25, 17), (30, 27, 8, 20, 4, 1, 9, 6, 23, 16), (10, 27, 15, 17, 14, 9, 19, 22, 7, 19), (29, 5, 14, 23, 23, 29, 13, 19, 1, 14), (7, 30, 29, 23, 27, 2, 3, 8, 10, 14), (7, 10, 10, 10, 30, 5, 7, 29, 7, 23), (2, 1, 11, 19, 23, 9, 14, 16, 13, 25), (5, 10, 2, 24, 16, 21, 21, 30, 14, 12), (25, 19, 9, 29, 21, 29, 10, 4, 19, 25), (30, 18, 3, 8, 9, 6, 13, 17, 1, 19), (7, 30, 18, 16, 25, 15, 10, 17, 18, 12), (21, 10, 13, 2, 12, 25, 25, 2, 27, 19), (17, 7, 18, 22, 24, 10, 8, 3, 26, 3), (3, 22, 19, 23, 30, 20, 1, 25, 18, 27), (8, 2, 15, 23, 28, 18, 4, 20, 7, 7), (4, 8, 29, 22, 20, 8, 18, 29, 13, 2), (20, 5, 8, 8, 20, 17, 2, 17, 29, 2), (4, 27, 8, 20, 18, 2, 18, 21, 6, 16), (8, 11, 24, 10, 20, 6, 16, 17, 13, 23), (22, 8, 21, 25, 17, 13, 9, 21, 4, 19), (18, 23, 22, 22, 2, 15, 25, 18, 30, 7), (2, 5, 5, 21, 18, 6, 27, 5, 30, 6), (28, 4, 17, 15, 27, 7, 27, 5, 9, 19), (8, 7, 4, 28, 22, 1, 28, 10, 14, 8), (6, 7, 30, 26, 5, 15, 21, 28, 1, 21), (20, 11, 8, 18, 17, 1, 24, 11, 22, 6), (23, 5, 29, 8, 10, 8, 28, 6, 5, 3), (8, 8, 17, 23, 23, 10, 9, 27, 10, 20), (3, 7, 29, 26, 1, 16, 1, 30, 5, 4), (23, 22, 17, 2, 15, 16, 17, 7, 20, 13), (1, 14, 3, 21, 14, 5, 24, 29, 5, 4), (6, 14, 26, 18, 29, 7, 2, 19, 19, 24), (24, 24, 10, 14, 22, 6, 17, 13, 3, 6), (5, 17, 2, 30, 26, 6, 21, 13, 11, 7), (11, 20, 15, 29, 20, 2, 23, 6, 28, 9), (27, 10, 3, 16, 21, 22, 8, 5, 19, 14), (21, 25, 23, 24, 7, 3, 30, 8, 21, 19), (10, 9, 17, 15, 14, 2, 5, 19, 28, 9), (1, 4, 3, 1, 22, 27, 15, 26, 1, 9), (8, 19, 18, 12, 26, 18, 1, 5, 19, 16), (6, 30, 11, 8, 22, 1, 24, 10, 30, 5), (10, 11, 12, 14, 24, 27, 22, 8, 11, 27), (8, 29, 17, 19, 20, 17, 4, 9, 3, 1), (17, 15, 1, 17, 22, 30, 1, 22, 3, 23), (1, 11, 15, 8, 6, 22, 4, 24, 18, 3), (23, 21, 24, 2, 17, 14, 14, 7, 18, 27), (30, 3, 25, 17, 25, 3, 5, 8, 4, 24), (4, 29, 30, 7, 14, 27, 25, 11, 18, 19), (2, 26, 15, 13, 16, 8, 7, 11, 21, 23), (9, 22, 28, 29, 18, 9, 22, 25, 26, 20), (21, 15, 29, 18, 24, 29, 20, 17, 2, 29), (12, 17, 11, 9, 4, 6, 2, 4, 22, 25), (17, 9, 9, 19, 3, 8, 6, 22, 12, 15), (28, 19, 25, 28, 1, 15, 8, 7, 6, 4), (17, 17, 22, 7, 1, 21, 25, 23, 22, 14), (19, 1, 7, 3, 11, 9, 7, 24, 2, 4), (17, 27, 18, 29, 8, 2, 17, 17, 13, 30), (8, 14, 14, 11, 26, 20, 28, 25, 13, 17), (10, 17, 7, 26, 24, 4, 10, 17, 2, 15), (21, 9, 29, 7, 13, 10, 13, 17, 2, 2), (16, 10, 18, 27, 26, 26, 3, 30, 14, 1), (9, 15, 11, 9, 2, 11, 3, 13, 29, 20), (18, 9, 22, 25, 15, 5, 21, 2, 13, 20), (9, 22, 15, 11, 24, 27, 22, 12, 16, 6), (4, 6, 20, 5, 25, 20, 3, 21, 26, 30), (24, 7, 19, 19, 27, 26, 3, 9, 13, 13), (27, 22, 8, 27, 13, 24, 23, 1, 26, 28), (12, 29, 7, 6, 25, 17, 22, 10, 6, 24), (2, 25, 30, 13, 10, 11, 20, 8, 10, 2), (28, 14, 11, 23, 28, 26, 2, 28, 28, 24), (8, 3, 24, 9, 10, 19, 11, 7, 5, 3), (25, 11, 27, 7, 4, 18, 14, 17, 3, 8), (2, 2, 20, 6, 26, 28, 7, 22, 2, 3), (29, 15, 23, 30, 23, 30, 1, 13, 12, 3), (18, 2, 4, 21, 23, 16, 17, 15, 9, 17), (28, 22, 12, 16, 8, 20, 14, 8, 2, 10), (28, 6, 18, 9, 4, 17, 11, 5, 19, 16), (27, 15, 27, 2, 4, 21, 21, 9, 10, 13), (5, 23, 13, 9, 28, 19, 5, 5, 14, 27), (7, 15, 2, 12, 9, 6, 12, 23, 25, 25), (7, 17, 17, 11, 20, 5, 13, 27, 27, 6), (7, 30, 14, 22, 16, 16, 11, 30, 29, 8)])" text ‹a randomly generated 20-dimensional zonotope* with 50 generators› definition random_zono3:: "(real*real*real*real*real*real*real*real*real*real* real*real*real*real*real*real*real*real*real*real) aform" where "random_zono3 = (0, pdevs_of_list [(30, 22, 14, 3, 15, 10, 9, 9, 18, 22, 24, 27, 24, 5, 24, 18, 16, 4, 13, 21), (30, 10, 25, 6, 5, 10, 7, 13, 14, 27, 30, 30, 6, 21, 12, 28, 1, 1, 24, 18), (25, 14, 10, 30, 9, 5, 2, 11, 11, 11, 26, 8, 12, 18, 5, 10, 17, 15, 30, 24), (30, 27, 21, 21, 27, 23, 7, 1, 22, 4, 13, 3, 20, 12, 4, 14, 13, 13, 4, 28), (9, 22, 4, 13, 19, 26, 8, 19, 28, 24, 14, 1, 30, 14, 9, 20, 12, 12, 14, 1), (7, 6, 13, 1, 21, 28, 23, 1, 26, 16, 6, 25, 12, 26, 17, 13, 30, 12, 28, 25), (12, 12, 30, 23, 15, 11, 7, 8, 11, 20, 8, 17, 16, 20, 18, 9, 9, 11, 9, 18), (9, 3, 13, 16, 28, 6, 28, 4, 1, 20, 23, 19, 12, 9, 11, 26, 2, 24, 8, 10), (3, 9, 11, 22, 29, 17, 1, 16, 27, 6, 16, 3, 24, 20, 20, 14, 4, 14, 21, 11), (16, 7, 9, 30, 14, 22, 1, 11, 7, 8, 18, 21, 24, 18, 27, 22, 17, 26, 21, 6), (4, 4, 4, 24, 24, 22, 28, 24, 25, 14, 2, 22, 6, 24, 19, 14, 13, 11, 8, 1), (30, 9, 12, 17, 23, 11, 18, 1, 19, 3, 18, 26, 19, 16, 21, 10, 23, 28, 17, 11), (5, 5, 25, 22, 15, 24, 4, 17, 18, 23, 29, 12, 18, 20, 27, 13, 4, 29, 6, 23), (29, 14, 14, 17, 20, 17, 1, 27, 5, 4, 3, 4, 7, 12, 12, 21, 14, 21, 13, 11), (3, 21, 14, 3, 14, 27, 5, 22, 22, 3, 4, 1, 24, 17, 1, 7, 7, 24, 16, 6), (14, 2, 24, 16, 10, 11, 23, 30, 14, 19, 16, 16, 22, 12, 28, 19, 12, 25, 17, 11), (8, 23, 19, 25, 5, 30, 22, 13, 28, 28, 23, 7, 24, 29, 3, 13, 2, 7, 6, 10), (4, 10, 13, 5, 15, 22, 11, 20, 4, 9, 11, 17, 16, 30, 1, 12, 29, 7, 20, 11), (19, 6, 22, 17, 9, 3, 6, 13, 18, 21, 21, 27, 4, 23, 18, 5, 23, 16, 21, 1), (2, 8, 16, 16, 8, 21, 19, 22, 10, 28, 7, 11, 21, 3, 18, 30, 15, 21, 3, 16), (7, 8, 8, 19, 21, 13, 7, 7, 29, 16, 10, 5, 21, 28, 16, 19, 11, 21, 13, 23), (26, 7, 26, 14, 9, 18, 10, 24, 20, 2, 5, 1, 15, 21, 29, 24, 27, 20, 24, 16), (4, 14, 10, 8, 22, 20, 1, 4, 1, 25, 17, 15, 16, 2, 30, 10, 29, 11, 29, 17), (21, 12, 16, 3, 28, 7, 3, 8, 12, 19, 24, 12, 6, 14, 18, 16, 24, 12, 21, 2), (7, 30, 25, 20, 23, 14, 17, 17, 18, 27, 24, 17, 3, 19, 7, 10, 19, 14, 24, 6), (12, 16, 26, 29, 27, 1, 18, 3, 14, 4, 27, 28, 24, 4, 18, 25, 25, 7, 12, 30), (19, 30, 30, 15, 16, 4, 12, 16, 27, 24, 22, 28, 13, 14, 22, 17, 18, 21, 7, 19), (9, 9, 23, 5, 1, 23, 9, 26, 23, 13, 19, 14, 29, 27, 23, 25, 2, 13, 18, 11), (12, 8, 20, 14, 14, 23, 24, 11, 8, 6, 25, 27, 28, 3, 4, 15, 1, 22, 19, 22), (19, 23, 28, 13, 2, 5, 17, 1, 17, 19, 30, 7, 6, 29, 7, 12, 11, 20, 30, 23), (27, 10, 21, 19, 24, 17, 10, 22, 22, 26, 2, 25, 8, 1, 5, 9, 22, 18, 28, 6), (9, 22, 9, 13, 20, 10, 6, 23, 7, 10, 29, 5, 28, 30, 22, 23, 8, 10, 14, 11), (14, 16, 20, 4, 25, 1, 10, 20, 13, 29, 17, 14, 21, 30, 21, 16, 10, 19, 6, 16), (25, 3, 6, 20, 18, 23, 3, 12, 14, 9, 2, 2, 30, 19, 12, 29, 23, 20, 29, 22), (20, 15, 11, 23, 5, 17, 13, 2, 4, 20, 16, 7, 7, 24, 7, 10, 13, 22, 9, 15), (8, 12, 30, 22, 11, 26, 25, 16, 27, 2, 9, 15, 15, 13, 30, 21, 4, 3, 1, 5), (23, 26, 23, 29, 26, 24, 8, 15, 22, 5, 26, 6, 2, 3, 17, 5, 14, 25, 28, 10), (20, 28, 25, 20, 9, 22, 1, 5, 24, 8, 10, 19, 3, 26, 21, 1, 13, 15, 3, 3), (9, 24, 1, 5, 22, 11, 11, 22, 25, 25, 16, 25, 24, 28, 15, 26, 22, 1, 23, 9), (13, 1, 11, 16, 6, 12, 11, 8, 29, 21, 23, 21, 21, 20, 5, 26, 2, 23, 2, 16), (12, 13, 5, 24, 25, 19, 26, 4, 17, 5, 18, 6, 2, 29, 21, 3, 10, 20, 7, 5), (26, 10, 13, 17, 29, 22, 3, 3, 28, 11, 5, 8, 11, 11, 17, 27, 19, 17, 23, 8), (2, 4, 11, 17, 18, 23, 14, 22, 4, 29, 2, 29, 25, 3, 4, 13, 2, 14, 5, 15), (12, 6, 16, 4, 25, 22, 29, 21, 2, 27, 17, 4, 11, 22, 2, 2, 5, 9, 28, 8), (3, 26, 17, 3, 29, 17, 16, 24, 10, 9, 16, 4, 23, 14, 10, 12, 16, 28, 28, 28), (7, 15, 28, 6, 25, 24, 11, 26, 22, 3, 28, 17, 10, 17, 19, 12, 20, 18, 29, 23), (24, 7, 7, 26, 17, 23, 19, 29, 1, 28, 11, 30, 23, 25, 30, 2, 6, 21, 1, 16), (6, 27, 22, 25, 9, 1, 16, 2, 12, 30, 23, 19, 12, 29, 20, 16, 16, 16, 6, 21), (25, 12, 5, 28, 19, 9, 25, 12, 10, 27, 10, 26, 27, 15, 2, 4, 23, 12, 20, 27)])" fun random_inter1 where "random_inter1 () = the (inter_aform_plane_ortho 53 random_zono (1, 15, 26, 8, 15, 23, 5, 14, 8, 8) 12)" fun random_inter2 where "random_inter2 () = the (inter_aform_plane_ortho 53 random_zono2 (13, 23, 22, 30, 27, 19, 17, 11, 24, 29) 12)" fun random_inter3 where "random_inter3 () = the (inter_aform_plane_ortho 53 random_zono3 (7, 10, 24, 12, 6, 14, 10, 14, 23, 13, 25, 27, 20, 2, 1, 9, 4, 17, 28, 19) 12)" ML ‹ val ri1 = @{code random_inter1} val ri2 = @{code random_inter2} val ri3 = @{code random_inter3} › text ‹Timings› ML ‹ fun iter f 0 = f () | iter f i = let val _ = f () in iter f (i - 1) end › ML ‹iter ri1 100› ― ‹0.7 s› ML ‹iter ri2 100› ― ‹1.3 s› ML ‹iter ri3 100› ― ‹1.3 s› end
theory Affine_Arithmetic imports Affine_Code Intersection Straight_Line_Program Ex_Affine_Approximation Ex_Ineqs Ex_Inter begin end